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