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 (defknown ash-left-constant-mod32 (integer (integer 0)) (unsigned-byte 32)
 592   (foldable flushable movable))
 593 (define-vop (fast-ash-left-constant-mod32/unsigned=>unsigned
 594              fast-ash-c/unsigned=>unsigned)
 595   (:translate ash-left-constant-mod32))
 596
 597 (define-modular-fun lognot-mod32 (x) lognot 32)
 598 (define-vop (lognot-mod32/unsigned=>unsigned)
 599   (:translate lognot-mod32)
 600   (:args (x :scs (unsigned-reg)))
 601   (:arg-types unsigned-num)
 602   (:results (res :scs (unsigned-reg)))
 603   (:result-types unsigned-num)
 604   (:policy :fast-safe)
 605   (:generator 1
 606     (inst uaddcm zero-tn x res)))
 607
 608 (macrolet
 609     ((define-modular-backend (fun)
 610        (let ((mfun-name (symbolicate fun '-mod32))
 611              ;; FIXME: if anyone cares, add constant-arg vops.  --
 612              ;; CSR, 2003-09-16
 613              (modvop (symbolicate 'fast- fun '-mod32/unsigned=>unsigned))
 614              (vop (symbolicate 'fast- fun '/unsigned=>unsigned)))
 615          `(progn
 616             (define-modular-fun ,mfun-name (x y) ,fun 32)
 617             (define-vop (,modvop ,vop)
 618               (:translate ,mfun-name))))))
 619   (define-modular-backend logxor)
 620   (define-modular-backend logandc1)
 621   (define-modular-backend logandc2))
 622
 623 (define-source-transform logeqv (&rest args)
 624   (if (oddp (length args))
 625       `(logxor ,@args)
 626       `(lognot (logxor ,@args))))
 627 (define-source-transform logorc1 (x y)
 628   `(logior (lognot ,x) ,y))
 629 (define-source-transform logorc2 (x y)
 630   `(logior ,x (lognot ,y)))
 631 (define-source-transform lognand (x y)
 632   `(lognot (logand ,x ,y)))
 633 (define-source-transform lognor (x y)
 634   `(lognot (logior ,x y)))
 635
 636 ;;;; 32-bit logical operations
 637
 638 (define-source-transform 32bit-logical-not (x)
 639   `(logand (lognot (the (unsigned-byte 32) ,x)) #.(1- (ash 1 32))))
 640
 641 (deftransform 32bit-logical-and ((x y))
 642   '(logand x y))
 643
 644 (define-source-transform 32bit-logical-nand (x y)
 645   `(32bit-logical-not (32bit-logical-and ,x ,y)))
 646
 647 (deftransform 32bit-logical-or ((x y))
 648   '(logior x y))
 649
 650 (define-source-transform 32bit-logical-nor (x y)
 651   `(logand (lognor (the (unsigned-byte 32) ,x) (the (unsigned-byte 32) ,y))
 652            #.(1- (ash 1 32))))
 653
 654 (deftransform 32bit-logical-xor ((x y))
 655   '(logxor x y))
 656
 657 (define-source-transform 32bit-logical-eqv (x y)
 658   `(32bit-logical-not (32bit-logical-xor ,x ,y)))
 659
 660 (define-source-transform 32bit-logical-orc1 (x y)
 661   `(32bit-logical-or (32bit-logical-not ,x) ,y))
 662
 663 (define-source-transform 32bit-logical-orc2 (x y)
 664   `(32bit-logical-or ,x (32bit-logical-not ,y)))
 665
 666 (deftransform 32bit-logical-andc1 (x y)
 667   '(logandc1 x y))
 668
 669 (deftransform 32bit-logical-andc2 (x y)
 670   '(logandc2 x y))
 671
 672 (define-vop (shift-towards-someplace)
 673   (:policy :fast-safe)
 674   (:args (num :scs (unsigned-reg))
 675          (amount :scs (signed-reg)))
 676   (:arg-types unsigned-num tagged-num)
 677   (:results (r :scs (unsigned-reg)))
 678   (:result-types unsigned-num))
 679
 680 (define-vop (shift-towards-start shift-towards-someplace)
 681   (:translate shift-towards-start)
 682   (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
 683   (:note "SHIFT-TOWARDS-START")
 684   (:generator 1
 685     (inst subi 31 amount temp)
 686     (inst mtctl temp :sar)
 687     (inst zdep num :variable 32 r)))
 688
 689 (define-vop (shift-towards-end shift-towards-someplace)
 690   (:translate shift-towards-end)
 691   (:note "SHIFT-TOWARDS-END")
 692   (:generator 1
 693     (inst mtctl amount :sar)
 694     (inst shd zero-tn num :variable r)))
 695
 696
 697 \f
 698 ;;;; Bignum stuff.
 699
 700 (define-vop (bignum-length get-header-data)
 701   (:translate sb!bignum::%bignum-length)
 702   (:policy :fast-safe))
 703
 704 (define-vop (bignum-set-length set-header-data)
 705   (:translate sb!bignum::%bignum-set-length)
 706   (:policy :fast-safe))
 707
 708 (define-full-reffer bignum-ref * bignum-digits-offset other-pointer-lowtag
 709   (unsigned-reg) unsigned-num sb!bignum::%bignum-ref)
 710
 711 (define-full-setter bignum-set * bignum-digits-offset other-pointer-lowtag
 712   (unsigned-reg) unsigned-num sb!bignum::%bignum-set)
 713
 714 (define-vop (digit-0-or-plus)
 715   (:translate sb!bignum::%digit-0-or-plusp)
 716   (:policy :fast-safe)
 717   (:args (digit :scs (unsigned-reg)))
 718   (:arg-types unsigned-num)
 719   (:conditional)
 720   (:info target not-p)
 721   (:effects)
 722   (:affected)
 723   (:generator 1
 724     (inst bc :>= not-p digit zero-tn target)))
 725
 726 (define-vop (add-w/carry)
 727   (:translate sb!bignum::%add-with-carry)
 728   (:policy :fast-safe)
 729   (:args (a :scs (unsigned-reg))
 730          (b :scs (unsigned-reg))
 731          (c :scs (unsigned-reg)))
 732   (:arg-types unsigned-num unsigned-num positive-fixnum)
 733   (:results (result :scs (unsigned-reg))
 734             (carry :scs (unsigned-reg)))
 735   (:result-types unsigned-num positive-fixnum)
 736   (:generator 3
 737     (inst addi -1 c zero-tn)
 738     (inst addc a b result)
 739     (inst addc zero-tn zero-tn carry)))
 740
 741 (define-vop (sub-w/borrow)
 742   (:translate sb!bignum::%subtract-with-borrow)
 743   (:policy :fast-safe)
 744   (:args (a :scs (unsigned-reg))
 745          (b :scs (unsigned-reg))
 746          (c :scs (unsigned-reg)))
 747   (:arg-types unsigned-num unsigned-num positive-fixnum)
 748   (:results (result :scs (unsigned-reg))
 749             (borrow :scs (unsigned-reg)))
 750   (:result-types unsigned-num positive-fixnum)
 751   (:generator 4
 752     (inst addi -1 c zero-tn)
 753     (inst subb a b result)
 754     (inst addc zero-tn zero-tn borrow)))
 755
 756 (define-vop (bignum-mult)
 757   (:translate sb!bignum::%multiply)
 758   (:policy :fast-safe)
 759   (:args (x-arg :scs (unsigned-reg) :target x)
 760          (y-arg :scs (unsigned-reg) :target y))
 761   (:arg-types unsigned-num unsigned-num)
 762   (:temporary (:scs (signed-reg) :from (:argument 0)) x)
 763   (:temporary (:scs (signed-reg) :from (:argument 1)) y)
 764   (:temporary (:scs (signed-reg)) tmp)
 765   (:results (hi :scs (unsigned-reg))
 766             (lo :scs (unsigned-reg)))
 767   (:result-types unsigned-num unsigned-num)
 768   (:generator 3
 769     ;; Make sure X is less then Y.
 770     (inst comclr x-arg y-arg tmp :<<)
 771     (inst xor x-arg y-arg tmp)
 772     (inst xor x-arg tmp x)
 773     (inst xor y-arg tmp y)
 774
 775     ;; Blow out of here if the result is zero.
 776     (inst li 0 hi)
 777     (inst comb := x zero-tn done)
 778     (inst li 0 lo)
 779     (inst li 0 tmp)
 780
 781     LOOP
 782     (inst comb :ev x zero-tn next-bit)
 783     (inst srl x 1 x)
 784     (inst add lo y lo)
 785     (inst addc hi tmp hi)
 786     NEXT-BIT
 787     (inst add y y y)
 788     (inst comb :<> x zero-tn loop)
 789     (inst addc tmp tmp tmp)
 790
 791     DONE))
 792
 793 (define-source-transform sb!bignum:%multiply-and-add (x y carry &optional (extra 0))
 794   #+nil ;; This would be greate if it worked, but it doesn't.
 795   (if (eql extra 0)
 796       `(multiple-value-call #'sb!bignum::%dual-word-add
 797          (sb!bignum:%multiply ,x ,y)
 798          (values ,carry))
 799       `(multiple-value-call #'sb!bignum::%dual-word-add
 800          (multiple-value-call #'sb!bignum::%dual-word-add
 801            (sb!bignum:%multiply ,x ,y)
 802            (values ,carry))
 803          (values ,extra)))
 804   (with-unique-names (hi lo)
 805     (if (eql extra 0)
 806         `(multiple-value-bind (,hi ,lo) (sb!bignum:%multiply ,x ,y)
 807            (sb!bignum::%dual-word-add ,hi ,lo ,carry))
 808         `(multiple-value-bind (,hi ,lo) (sb!bignum:%multiply ,x ,y)
 809            (multiple-value-bind
 810                (,hi ,lo)
 811                (sb!bignum::%dual-word-add ,hi ,lo ,carry)
 812              (sb!bignum::%dual-word-add ,hi ,lo ,extra))))))
 813
 814 (defknown sb!bignum::%dual-word-add
 815           (sb!bignum:bignum-element-type sb!bignum:bignum-element-type sb!bignum:bignum-element-type)
 816   (values sb!bignum:bignum-element-type sb!bignum:bignum-element-type)
 817   (flushable movable))
 818
 819 (define-vop (dual-word-add)
 820   (:policy :fast-safe)
 821   (:translate sb!bignum::%dual-word-add)
 822   (:args (hi :scs (unsigned-reg) :to (:result 1))
 823          (lo :scs (unsigned-reg))
 824          (extra :scs (unsigned-reg)))
 825   (:arg-types unsigned-num unsigned-num unsigned-num)
 826   (:results (hi-res :scs (unsigned-reg) :from (:result 1))
 827             (lo-res :scs (unsigned-reg) :from (:result 0)))
 828   (:result-types unsigned-num unsigned-num)
 829   (:affected)
 830   (:effects)
 831   (:generator 3
 832     (inst add lo extra lo-res)
 833     (inst addc hi zero-tn hi-res)))
 834
 835 (define-vop (bignum-lognot)
 836   (:translate sb!bignum::%lognot)
 837   (:policy :fast-safe)
 838   (:args (x :scs (unsigned-reg)))
 839   (:arg-types unsigned-num)
 840   (:results (r :scs (unsigned-reg)))
 841   (:result-types unsigned-num)
 842   (:generator 1
 843     (inst uaddcm zero-tn x r)))
 844
 845 (define-vop (fixnum-to-digit)
 846   (:translate sb!bignum::%fixnum-to-digit)
 847   (:policy :fast-safe)
 848   (:args (fixnum :scs (signed-reg)))
 849   (:arg-types tagged-num)
 850   (:results (digit :scs (unsigned-reg)))
 851   (:result-types unsigned-num)
 852   (:generator 1
 853     (move fixnum digit)))
 854
 855 (define-vop (bignum-floor)
 856   (:translate sb!bignum::%floor)
 857   (:policy :fast-safe)
 858   (:args (hi :scs (unsigned-reg) :to (:argument 1))
 859          (lo :scs (unsigned-reg) :to (:argument 0))
 860          (divisor :scs (unsigned-reg)))
 861   (:arg-types unsigned-num unsigned-num unsigned-num)
 862   (:temporary (:scs (unsigned-reg) :to (:argument 1)) temp)
 863   (:results (quo :scs (unsigned-reg) :from (:argument 0))
 864             (rem :scs (unsigned-reg) :from (:argument 1)))
 865   (:result-types unsigned-num unsigned-num)
 866   (:generator 65
 867     (inst sub zero-tn divisor temp)
 868     (inst ds zero-tn temp zero-tn)
 869     (inst add lo lo quo)
 870     (inst ds hi divisor rem)
 871     (inst addc quo quo quo)
 872     (dotimes (i 31)
 873       (inst ds rem divisor rem)
 874       (inst addc quo quo quo))
 875     (inst comclr rem zero-tn zero-tn :>=)
 876     (inst add divisor rem rem)))
 877
 878 (define-vop (signify-digit)
 879   (:translate sb!bignum::%fixnum-digit-with-correct-sign)
 880   (:policy :fast-safe)
 881   (:args (digit :scs (unsigned-reg) :target res))
 882   (:arg-types unsigned-num)
 883   (:results (res :scs (signed-reg)))
 884   (:result-types signed-num)
 885   (:generator 1
 886     (move digit res)))
 887
 888 (define-vop (digit-lshr)
 889   (:translate sb!bignum::%digit-logical-shift-right)
 890   (:policy :fast-safe)
 891   (:args (digit :scs (unsigned-reg))
 892          (count :scs (unsigned-reg)))
 893   (:arg-types unsigned-num positive-fixnum)
 894   (:results (result :scs (unsigned-reg)))
 895   (:result-types unsigned-num)
 896   (:generator 2
 897     (inst mtctl count :sar)
 898     (inst shd zero-tn digit :variable result)))
 899
 900 (define-vop (digit-ashr digit-lshr)
 901   (:translate sb!bignum::%ashr)
 902   (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
 903   (:generator 1
 904     (inst extrs digit 0 1 temp)
 905     (inst mtctl count :sar)
 906     (inst shd temp digit :variable result)))
 907
 908 (define-vop (digit-ashl digit-ashr)
 909   (:translate sb!bignum::%ashl)
 910   (:generator 1
 911     (inst subi 31 count temp)
 912     (inst mtctl temp :sar)
 913     (inst zdep digit :variable 32 result)))
 914
 915 \f
 916 ;;;; Static functions.
 917
 918 (define-static-fun two-arg-gcd (x y) :translate gcd)
 919 (define-static-fun two-arg-lcm (x y) :translate lcm)
 920
 921 (define-static-fun two-arg-* (x y) :translate *)
 922 (define-static-fun two-arg-/ (x y) :translate /)
 923
 924 (define-static-fun %negate (x) :translate %negate)
 925
 926 (define-static-fun two-arg-and (x y) :translate logand)
 927 (define-static-fun two-arg-ior (x y) :translate logior)
 928 (define-static-fun two-arg-xor (x y) :translate logxor)