src/compiler/x86-64/arith.lisp

   1 ;;;; the VM definition of arithmetic VOPs for the x86
   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) :target res))
  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) :target res))
  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     (move res x)
  39     (inst neg res)))
  40
  41 (define-vop (fast-negate/signed signed-unop)
  42   (:translate %negate)
  43   (:generator 2
  44     (move res x)
  45     (inst neg res)))
  46
  47 (define-vop (fast-lognot/fixnum fixnum-unop)
  48   (:translate lognot)
  49   (:generator 2
  50     (move res x)
  51     (inst xor res (fixnumize -1))))
  52
  53 (define-vop (fast-lognot/signed signed-unop)
  54   (:translate lognot)
  55   (:generator 1
  56     (move res x)
  57     (inst not res)))
  58 \f
  59 ;;;; binary fixnum operations
  60
  61 ;;; Assume that any constant operand is the second arg...
  62
  63 (define-vop (fast-fixnum-binop fast-safe-arith-op)
  64   (:args (x :target r :scs (any-reg)
  65             :load-if (not (and (sc-is x control-stack)
  66                                (sc-is y any-reg)
  67                                (sc-is r control-stack)
  68                                (location= x r))))
  69          (y :scs (any-reg control-stack)))
  70   (:arg-types tagged-num tagged-num)
  71   (:results (r :scs (any-reg) :from (:argument 0)
  72                :load-if (not (and (sc-is x control-stack)
  73                                   (sc-is y any-reg)
  74                                   (sc-is r control-stack)
  75                                   (location= x r)))))
  76   (:result-types tagged-num)
  77   (:note "inline fixnum arithmetic"))
  78
  79 (define-vop (fast-unsigned-binop fast-safe-arith-op)
  80   (:args (x :target r :scs (unsigned-reg)
  81             :load-if (not (and (sc-is x unsigned-stack)
  82                                (sc-is y unsigned-reg)
  83                                (sc-is r unsigned-stack)
  84                                (location= x r))))
  85          (y :scs (unsigned-reg unsigned-stack)))
  86   (:arg-types unsigned-num unsigned-num)
  87   (:results (r :scs (unsigned-reg) :from (:argument 0)
  88             :load-if (not (and (sc-is x unsigned-stack)
  89                                (sc-is y unsigned-reg)
  90                                (sc-is r unsigned-stack)
  91                                (location= x r)))))
  92   (:result-types unsigned-num)
  93   (:note "inline (unsigned-byte 32) arithmetic"))
  94
  95 (define-vop (fast-signed-binop fast-safe-arith-op)
  96   (:args (x :target r :scs (signed-reg)
  97             :load-if (not (and (sc-is x signed-stack)
  98                                (sc-is y signed-reg)
  99                                (sc-is r signed-stack)
 100                                (location= x r))))
 101          (y :scs (signed-reg signed-stack)))
 102   (:arg-types signed-num signed-num)
 103   (:results (r :scs (signed-reg) :from (:argument 0)
 104             :load-if (not (and (sc-is x signed-stack)
 105                                (sc-is y signed-reg)
 106                                (sc-is r signed-stack)
 107                                (location= x r)))))
 108   (:result-types signed-num)
 109   (:note "inline (signed-byte 32) arithmetic"))
 110
 111 (define-vop (fast-fixnum-binop-c fast-safe-arith-op)
 112   (:args (x :target r :scs (any-reg control-stack)))
 113   (:info y)
 114   (:arg-types tagged-num (:constant (signed-byte 29)))
 115   (:results (r :scs (any-reg)
 116                :load-if (not (location= x r))))
 117   (:result-types tagged-num)
 118   (:note "inline fixnum arithmetic"))
 119
 120 ;; 31 not 64 because it's hard work loading 64 bit constants, and since
 121 ;; sign-extension of immediates causes problems with 32.
 122 (define-vop (fast-unsigned-binop-c fast-safe-arith-op)
 123   (:args (x :target r :scs (unsigned-reg unsigned-stack)))
 124   (:info y)
 125   (:arg-types unsigned-num (:constant (unsigned-byte 31)))
 126   (:results (r :scs (unsigned-reg)
 127                :load-if (not (location= x r))))
 128   (:result-types unsigned-num)
 129   (:note "inline (unsigned-byte 32) arithmetic"))
 130
 131 ;; 32 not 64 because it's hard work loading 64 bit constants
 132 (define-vop (fast-signed-binop-c fast-safe-arith-op)
 133   (:args (x :target r :scs (signed-reg signed-stack)))
 134   (:info y)
 135   (:arg-types signed-num (:constant (signed-byte 32)))
 136   (:results (r :scs (signed-reg)
 137                :load-if (not (location= x r))))
 138   (:result-types signed-num)
 139   (:note "inline (signed-byte 32) arithmetic"))
 140
 141 (macrolet ((define-binop (translate untagged-penalty op)
 142              `(progn
 143                 (define-vop (,(symbolicate "FAST-" translate "/FIXNUM=>FIXNUM")
 144                              fast-fixnum-binop)
 145                   (:translate ,translate)
 146                   (:generator 2
 147                               (move r x)
 148                               (inst ,op r y)))
 149                 (define-vop (,(symbolicate 'fast- translate '-c/fixnum=>fixnum)
 150                              fast-fixnum-binop-c)
 151                   (:translate ,translate)
 152                   (:generator 1
 153                   (move r x)
 154                   (inst ,op r (fixnumize y))))
 155                 (define-vop (,(symbolicate "FAST-" translate "/SIGNED=>SIGNED")
 156                              fast-signed-binop)
 157                   (:translate ,translate)
 158                   (:generator ,(1+ untagged-penalty)
 159                   (move r x)
 160                   (inst ,op r y)))
 161                 (define-vop (,(symbolicate 'fast- translate '-c/signed=>signed)
 162                              fast-signed-binop-c)
 163                   (:translate ,translate)
 164                   (:generator ,untagged-penalty
 165                   (move r x)
 166                   (inst ,op r y)))
 167                 (define-vop (,(symbolicate "FAST-"
 168                                            translate
 169                                            "/UNSIGNED=>UNSIGNED")
 170                 fast-unsigned-binop)
 171                   (:translate ,translate)
 172                   (:generator ,(1+ untagged-penalty)
 173                   (move r x)
 174                   (inst ,op r y)))
 175                 (define-vop (,(symbolicate 'fast-
 176                                            translate
 177                                            '-c/unsigned=>unsigned)
 178                              fast-unsigned-binop-c)
 179                   (:translate ,translate)
 180                   (:generator ,untagged-penalty
 181                   (move r x)
 182                   (inst ,op r y))))))
 183
 184   ;;(define-binop + 4 add)
 185   (define-binop - 4 sub)
 186   (define-binop logand 2 and)
 187   (define-binop logior 2 or)
 188   (define-binop logxor 2 xor))
 189
 190 ;;; Special handling of add on the x86; can use lea to avoid a
 191 ;;; register load, otherwise it uses add.
 192 (define-vop (fast-+/fixnum=>fixnum fast-safe-arith-op)
 193   (:translate +)
 194   (:args (x :scs (any-reg) :target r
 195             :load-if (not (and (sc-is x control-stack)
 196                                (sc-is y any-reg)
 197                                (sc-is r control-stack)
 198                                (location= x r))))
 199          (y :scs (any-reg control-stack)))
 200   (:arg-types tagged-num tagged-num)
 201   (:results (r :scs (any-reg) :from (:argument 0)
 202                :load-if (not (and (sc-is x control-stack)
 203                                   (sc-is y any-reg)
 204                                   (sc-is r control-stack)
 205                                   (location= x r)))))
 206   (:result-types tagged-num)
 207   (:note "inline fixnum arithmetic")
 208   (:generator 2
 209     (cond ((and (sc-is x any-reg) (sc-is y any-reg) (sc-is r any-reg)
 210                 (not (location= x r)))
 211            (inst lea r (make-ea :qword :base x :index y :scale 1)))
 212           (t
 213            (move r x)
 214            (inst add r y)))))
 215
 216 (define-vop (fast-+-c/fixnum=>fixnum fast-safe-arith-op)
 217   (:translate +)
 218   (:args (x :target r :scs (any-reg control-stack)))
 219   (:info y)
 220   (:arg-types tagged-num (:constant (signed-byte 29)))
 221   (:results (r :scs (any-reg)
 222                :load-if (not (location= x r))))
 223   (:result-types tagged-num)
 224   (:note "inline fixnum arithmetic")
 225   (:generator 1
 226     (cond ((and (sc-is x any-reg) (sc-is r any-reg) (not (location= x r)))
 227            (inst lea r (make-ea :qword :base x :disp (fixnumize y))))
 228           (t
 229            (move r x)
 230            (inst add r (fixnumize y))))))
 231
 232 (define-vop (fast-+/signed=>signed fast-safe-arith-op)
 233   (:translate +)
 234   (:args (x :scs (signed-reg) :target r
 235             :load-if (not (and (sc-is x signed-stack)
 236                                (sc-is y signed-reg)
 237                                (sc-is r signed-stack)
 238                                (location= x r))))
 239          (y :scs (signed-reg signed-stack)))
 240   (:arg-types signed-num signed-num)
 241   (:results (r :scs (signed-reg) :from (:argument 0)
 242                :load-if (not (and (sc-is x signed-stack)
 243                                   (sc-is y signed-reg)
 244                                   (location= x r)))))
 245   (:result-types signed-num)
 246   (:note "inline (signed-byte 32) arithmetic")
 247   (:generator 5
 248     (cond ((and (sc-is x signed-reg) (sc-is y signed-reg) (sc-is r signed-reg)
 249                 (not (location= x r)))
 250            (inst lea r (make-ea :qword :base x :index y :scale 1)))
 251           (t
 252            (move r x)
 253            (inst add r y)))))
 254
 255
 256 ;;;; Special logand cases: (logand signed unsigned) => unsigned
 257
 258 (define-vop (fast-logand/signed-unsigned=>unsigned
 259              fast-logand/unsigned=>unsigned)
 260   (:args (x :target r :scs (signed-reg)
 261             :load-if (not (and (sc-is x signed-stack)
 262                                (sc-is y unsigned-reg)
 263                                (sc-is r unsigned-stack)
 264                                (location= x r))))
 265          (y :scs (unsigned-reg unsigned-stack)))
 266   (:arg-types signed-num unsigned-num))
 267
 268 (define-vop (fast-logand-c/signed-unsigned=>unsigned
 269              fast-logand-c/unsigned=>unsigned)
 270   (:args (x :target r :scs (signed-reg signed-stack)))
 271   (:arg-types signed-num (:constant (unsigned-byte 32))))
 272
 273 (define-vop (fast-logand/unsigned-signed=>unsigned
 274              fast-logand/unsigned=>unsigned)
 275   (:args (x :target r :scs (unsigned-reg)
 276             :load-if (not (and (sc-is x unsigned-stack)
 277                                (sc-is y signed-reg)
 278                                (sc-is r unsigned-stack)
 279                                (location= x r))))
 280          (y :scs (signed-reg signed-stack)))
 281   (:arg-types unsigned-num signed-num))
 282 \f
 283
 284 (define-vop (fast-+-c/signed=>signed fast-safe-arith-op)
 285   (:translate +)
 286   (:args (x :target r :scs (signed-reg signed-stack)))
 287   (:info y)
 288   (:arg-types signed-num (:constant (signed-byte 32)))
 289   (:results (r :scs (signed-reg)
 290                :load-if (not (location= x r))))
 291   (:result-types signed-num)
 292   (:note "inline (signed-byte 32) arithmetic")
 293   (:generator 4
 294     (cond ((and (sc-is x signed-reg) (sc-is r signed-reg)
 295                 (not (location= x r)))
 296            (inst lea r (make-ea :qword :base x :disp y)))
 297           (t
 298            (move r x)
 299            (if (= y 1)
 300                (inst inc r)
 301              (inst add r y))))))
 302
 303 (define-vop (fast-+/unsigned=>unsigned fast-safe-arith-op)
 304   (:translate +)
 305   (:args (x :scs (unsigned-reg) :target r
 306             :load-if (not (and (sc-is x unsigned-stack)
 307                                (sc-is y unsigned-reg)
 308                                (sc-is r unsigned-stack)
 309                                (location= x r))))
 310          (y :scs (unsigned-reg unsigned-stack)))
 311   (:arg-types unsigned-num unsigned-num)
 312   (:results (r :scs (unsigned-reg) :from (:argument 0)
 313                :load-if (not (and (sc-is x unsigned-stack)
 314                                   (sc-is y unsigned-reg)
 315                                   (sc-is r unsigned-stack)
 316                                   (location= x r)))))
 317   (:result-types unsigned-num)
 318   (:note "inline (unsigned-byte 32) arithmetic")
 319   (:generator 5
 320     (cond ((and (sc-is x unsigned-reg) (sc-is y unsigned-reg)
 321                 (sc-is r unsigned-reg) (not (location= x r)))
 322            (inst lea r (make-ea :qword :base x :index y :scale 1)))
 323           (t
 324            (move r x)
 325            (inst add r y)))))
 326
 327 (define-vop (fast-+-c/unsigned=>unsigned fast-safe-arith-op)
 328   (:translate +)
 329   (:args (x :target r :scs (unsigned-reg unsigned-stack)))
 330   (:info y)
 331   (:arg-types unsigned-num (:constant (unsigned-byte 32)))
 332   (:results (r :scs (unsigned-reg)
 333                :load-if (not (location= x r))))
 334   (:result-types unsigned-num)
 335   (:note "inline (unsigned-byte 32) arithmetic")
 336   (:generator 4
 337     (cond ((and (sc-is x unsigned-reg) (sc-is r unsigned-reg)
 338                 (not (location= x r)))
 339            (inst lea r (make-ea :qword :base x :disp y)))
 340           (t
 341            (move r x)
 342            (if (= y 1)
 343                (inst inc r)
 344              (inst add r y))))))
 345 \f
 346 ;;;; multiplication and division
 347
 348 (define-vop (fast-*/fixnum=>fixnum fast-safe-arith-op)
 349   (:translate *)
 350   ;; We need different loading characteristics.
 351   (:args (x :scs (any-reg) :target r)
 352          (y :scs (any-reg control-stack)))
 353   (:arg-types tagged-num tagged-num)
 354   (:results (r :scs (any-reg) :from (:argument 0)))
 355   (:result-types tagged-num)
 356   (:note "inline fixnum arithmetic")
 357   (:generator 4
 358     (move r x)
 359     (inst sar r 3)
 360     (inst imul r y)))
 361
 362 (define-vop (fast-*-c/fixnum=>fixnum fast-safe-arith-op)
 363   (:translate *)
 364   ;; We need different loading characteristics.
 365   (:args (x :scs (any-reg control-stack)))
 366   (:info y)
 367   (:arg-types tagged-num (:constant (signed-byte 29)))
 368   (:results (r :scs (any-reg)))
 369   (:result-types tagged-num)
 370   (:note "inline fixnum arithmetic")
 371   (:generator 3
 372     (inst imul r x y)))
 373
 374 (define-vop (fast-*/signed=>signed fast-safe-arith-op)
 375   (:translate *)
 376   ;; We need different loading characteristics.
 377   (:args (x :scs (signed-reg) :target r)
 378          (y :scs (signed-reg signed-stack)))
 379   (:arg-types signed-num signed-num)
 380   (:results (r :scs (signed-reg) :from (:argument 0)))
 381   (:result-types signed-num)
 382   (:note "inline (signed-byte 32) arithmetic")
 383   (:generator 5
 384     (move r x)
 385     (inst imul r y)))
 386
 387 (define-vop (fast-*-c/signed=>signed fast-safe-arith-op)
 388   (:translate *)
 389   ;; We need different loading characteristics.
 390   (:args (x :scs (signed-reg signed-stack)))
 391   (:info y)
 392   (:arg-types signed-num (:constant (signed-byte 32)))
 393   (:results (r :scs (signed-reg)))
 394   (:result-types signed-num)
 395   (:note "inline (signed-byte 32) arithmetic")
 396   (:generator 4
 397     (inst imul r x y)))
 398
 399 (define-vop (fast-*/unsigned=>unsigned fast-safe-arith-op)
 400   (:translate *)
 401   (:args (x :scs (unsigned-reg) :target eax)
 402          (y :scs (unsigned-reg unsigned-stack)))
 403   (:arg-types unsigned-num unsigned-num)
 404   (:temporary (:sc unsigned-reg :offset eax-offset :target result
 405                    :from (:argument 0) :to :result) eax)
 406   (:temporary (:sc unsigned-reg :offset edx-offset
 407                    :from :eval :to :result) edx)
 408   (:ignore edx)
 409   (:results (result :scs (unsigned-reg)))
 410   (:result-types unsigned-num)
 411   (:note "inline (unsigned-byte 32) arithmetic")
 412   (:vop-var vop)
 413   (:save-p :compute-only)
 414   (:generator 6
 415     (move eax x)
 416     (inst mul eax y)
 417     (move result eax)))
 418
 419
 420 (define-vop (fast-truncate/fixnum=>fixnum fast-safe-arith-op)
 421   (:translate truncate)
 422   (:args (x :scs (any-reg) :target eax)
 423          (y :scs (any-reg control-stack)))
 424   (:arg-types tagged-num tagged-num)
 425   (:temporary (:sc signed-reg :offset eax-offset :target quo
 426                    :from (:argument 0) :to (:result 0)) eax)
 427   (:temporary (:sc unsigned-reg :offset edx-offset :target rem
 428                    :from (:argument 0) :to (:result 1)) edx)
 429   (:results (quo :scs (any-reg))
 430             (rem :scs (any-reg)))
 431   (:result-types tagged-num tagged-num)
 432   (:note "inline fixnum arithmetic")
 433   (:vop-var vop)
 434   (:save-p :compute-only)
 435   (:generator 31
 436     (let ((zero (generate-error-code vop division-by-zero-error x y)))
 437       (if (sc-is y any-reg)
 438           (inst test y y)  ; smaller instruction
 439           (inst cmp y 0))
 440       (inst jmp :eq zero))
 441     (move eax x)
 442     (inst cqo)
 443     (inst idiv eax y)
 444     (if (location= quo eax)
 445         (inst shl eax 3)
 446         (inst lea quo (make-ea :qword :index eax :scale 8)))
 447     (move rem edx)))
 448
 449 (define-vop (fast-truncate-c/fixnum=>fixnum fast-safe-arith-op)
 450   (:translate truncate)
 451   (:args (x :scs (any-reg) :target eax))
 452   (:info y)
 453   (:arg-types tagged-num (:constant (signed-byte 29)))
 454   (:temporary (:sc signed-reg :offset eax-offset :target quo
 455                    :from :argument :to (:result 0)) eax)
 456   (:temporary (:sc any-reg :offset edx-offset :target rem
 457                    :from :eval :to (:result 1)) edx)
 458   (:temporary (:sc any-reg :from :eval :to :result) y-arg)
 459   (:results (quo :scs (any-reg))
 460             (rem :scs (any-reg)))
 461   (:result-types tagged-num tagged-num)
 462   (:note "inline fixnum arithmetic")
 463   (:vop-var vop)
 464   (:save-p :compute-only)
 465   (:generator 30
 466     (move eax x)
 467     (inst cqo)
 468     (inst mov y-arg (fixnumize y))
 469     (inst idiv eax y-arg)
 470     (if (location= quo eax)
 471         (inst shl eax 3)
 472         (inst lea quo (make-ea :qword :index eax :scale 8)))
 473     (move rem edx)))
 474
 475 (define-vop (fast-truncate/unsigned=>unsigned fast-safe-arith-op)
 476   (:translate truncate)
 477   (:args (x :scs (unsigned-reg) :target eax)
 478          (y :scs (unsigned-reg signed-stack)))
 479   (:arg-types unsigned-num unsigned-num)
 480   (:temporary (:sc unsigned-reg :offset eax-offset :target quo
 481                    :from (:argument 0) :to (:result 0)) eax)
 482   (:temporary (:sc unsigned-reg :offset edx-offset :target rem
 483                    :from (:argument 0) :to (:result 1)) edx)
 484   (:results (quo :scs (unsigned-reg))
 485             (rem :scs (unsigned-reg)))
 486   (:result-types unsigned-num unsigned-num)
 487   (:note "inline (unsigned-byte 32) arithmetic")
 488   (:vop-var vop)
 489   (:save-p :compute-only)
 490   (:generator 33
 491     (let ((zero (generate-error-code vop division-by-zero-error x y)))
 492       (if (sc-is y unsigned-reg)
 493           (inst test y y)  ; smaller instruction
 494           (inst cmp y 0))
 495       (inst jmp :eq zero))
 496     (move eax x)
 497     (inst xor edx edx)
 498     (inst div eax y)
 499     (move quo eax)
 500     (move rem edx)))
 501
 502 (define-vop (fast-truncate-c/unsigned=>unsigned fast-safe-arith-op)
 503   (:translate truncate)
 504   (:args (x :scs (unsigned-reg) :target eax))
 505   (:info y)
 506   (:arg-types unsigned-num (:constant (unsigned-byte 32)))
 507   (:temporary (:sc unsigned-reg :offset eax-offset :target quo
 508                    :from :argument :to (:result 0)) eax)
 509   (:temporary (:sc unsigned-reg :offset edx-offset :target rem
 510                    :from :eval :to (:result 1)) edx)
 511   (:temporary (:sc unsigned-reg :from :eval :to :result) y-arg)
 512   (:results (quo :scs (unsigned-reg))
 513             (rem :scs (unsigned-reg)))
 514   (:result-types unsigned-num unsigned-num)
 515   (:note "inline (unsigned-byte 32) arithmetic")
 516   (:vop-var vop)
 517   (:save-p :compute-only)
 518   (:generator 32
 519     (move eax x)
 520     (inst xor edx edx)
 521     (inst mov y-arg y)
 522     (inst div eax y-arg)
 523     (move quo eax)
 524     (move rem edx)))
 525
 526 (define-vop (fast-truncate/signed=>signed fast-safe-arith-op)
 527   (:translate truncate)
 528   (:args (x :scs (signed-reg) :target eax)
 529          (y :scs (signed-reg signed-stack)))
 530   (:arg-types signed-num signed-num)
 531   (:temporary (:sc signed-reg :offset eax-offset :target quo
 532                    :from (:argument 0) :to (:result 0)) eax)
 533   (:temporary (:sc signed-reg :offset edx-offset :target rem
 534                    :from (:argument 0) :to (:result 1)) edx)
 535   (:results (quo :scs (signed-reg))
 536             (rem :scs (signed-reg)))
 537   (:result-types signed-num signed-num)
 538   (:note "inline (signed-byte 32) arithmetic")
 539   (:vop-var vop)
 540   (:save-p :compute-only)
 541   (:generator 33
 542     (let ((zero (generate-error-code vop division-by-zero-error x y)))
 543       (if (sc-is y signed-reg)
 544           (inst test y y)  ; smaller instruction
 545           (inst cmp y 0))
 546       (inst jmp :eq zero))
 547     (move eax x)
 548     (inst cqo)
 549     (inst idiv eax y)
 550     (move quo eax)
 551     (move rem edx)))
 552
 553 (define-vop (fast-truncate-c/signed=>signed fast-safe-arith-op)
 554   (:translate truncate)
 555   (:args (x :scs (signed-reg) :target eax))
 556   (:info y)
 557   (:arg-types signed-num (:constant (signed-byte 32)))
 558   (:temporary (:sc signed-reg :offset eax-offset :target quo
 559                    :from :argument :to (:result 0)) eax)
 560   (:temporary (:sc signed-reg :offset edx-offset :target rem
 561                    :from :eval :to (:result 1)) edx)
 562   (:temporary (:sc signed-reg :from :eval :to :result) y-arg)
 563   (:results (quo :scs (signed-reg))
 564             (rem :scs (signed-reg)))
 565   (:result-types signed-num signed-num)
 566   (:note "inline (signed-byte 32) arithmetic")
 567   (:vop-var vop)
 568   (:save-p :compute-only)
 569   (:generator 32
 570     (move eax x)
 571     (inst cqo)
 572     (inst mov y-arg y)
 573     (inst idiv eax y-arg)
 574     (move quo eax)
 575     (move rem edx)))
 576
 577
 578 \f
 579 ;;;; Shifting
 580 (define-vop (fast-ash-c/fixnum=>fixnum)
 581   (:translate ash)
 582   (:policy :fast-safe)
 583   (:args (number :scs (any-reg) :target result
 584                  :load-if (not (and (sc-is number any-reg control-stack)
 585                                     (sc-is result any-reg control-stack)
 586                                     (location= number result)))))
 587   (:info amount)
 588   (:arg-types tagged-num (:constant integer))
 589   (:results (result :scs (any-reg)
 590                     :load-if (not (and (sc-is number control-stack)
 591                                        (sc-is result control-stack)
 592                                        (location= number result)))))
 593   (:result-types tagged-num)
 594   (:note "inline ASH")
 595   (:generator 2
 596     (cond ((and (= amount 1) (not (location= number result)))
 597            (inst lea result (make-ea :qword :index number :scale 2)))
 598           ((and (= amount 2) (not (location= number result)))
 599            (inst lea result (make-ea :qword :index number :scale 4)))
 600           ((and (= amount 3) (not (location= number result)))
 601            (inst lea result (make-ea :qword :index number :scale 8)))
 602           (t
 603            (move result number)
 604            (cond ((plusp amount)
 605                   ;; We don't have to worry about overflow because of the
 606                   ;; result type restriction.
 607                   (inst shl result amount))
 608                  (t
 609                   ;; Since the shift instructions take the shift amount
 610                   ;; modulo 64 we must special case amounts of 64 and more.
 611                   ;; Because fixnums have only 61 bits, the result is 0 or
 612                   ;; -1 for all amounts of 60 or more, so use this as the
 613                   ;; limit instead.
 614                   (inst sar result (min (- n-word-bits n-fixnum-tag-bits 1)
 615                                         (- amount)))
 616                   (inst and result (lognot fixnum-tag-mask))))))))
 617
 618 (define-vop (fast-ash-left/fixnum=>fixnum)
 619   (:translate ash)
 620   (:args (number :scs (any-reg) :target result
 621                  :load-if (not (and (sc-is number control-stack)
 622                                     (sc-is result control-stack)
 623                                     (location= number result))))
 624          (amount :scs (unsigned-reg) :target ecx))
 625   (:arg-types tagged-num positive-fixnum)
 626   (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
 627   (:results (result :scs (any-reg) :from (:argument 0)
 628                     :load-if (not (and (sc-is number control-stack)
 629                                        (sc-is result control-stack)
 630                                        (location= number result)))))
 631   (:result-types tagged-num)
 632   (:policy :fast-safe)
 633   (:note "inline ASH")
 634   (:generator 3
 635     (move result number)
 636     (move ecx amount)
 637     ;; The result-type ensures us that this shift will not overflow.
 638     (inst shl result :cl)))
 639
 640 (define-vop (fast-ash-c/signed=>signed)
 641   (:translate ash)
 642   (:policy :fast-safe)
 643   (:args (number :scs (signed-reg) :target result
 644                  :load-if (not (and (sc-is number signed-stack)
 645                                     (sc-is result signed-stack)
 646                                     (location= number result)))))
 647   (:info amount)
 648   (:arg-types signed-num (:constant integer))
 649   (:results (result :scs (signed-reg)
 650                     :load-if (not (and (sc-is number signed-stack)
 651                                        (sc-is result signed-stack)
 652                                        (location= number result)))))
 653   (:result-types signed-num)
 654   (:note "inline ASH")
 655   (:generator 3
 656     (cond ((and (= amount 1) (not (location= number result)))
 657            (inst lea result (make-ea :qword :index number :scale 2)))
 658           ((and (= amount 2) (not (location= number result)))
 659            (inst lea result (make-ea :qword :index number :scale 4)))
 660           ((and (= amount 3) (not (location= number result)))
 661            (inst lea result (make-ea :qword :index number :scale 8)))
 662           (t
 663            (move result number)
 664            (cond ((plusp amount) (inst shl result amount))
 665                  (t (inst sar result (min 63 (- amount)))))))))
 666
 667 (define-vop (fast-ash-c/unsigned=>unsigned)
 668   (:translate ash)
 669   (:policy :fast-safe)
 670   (:args (number :scs (unsigned-reg) :target result
 671                  :load-if (not (and (sc-is number unsigned-stack)
 672                                     (sc-is result unsigned-stack)
 673                                     (location= number result)))))
 674   (:info amount)
 675   (:arg-types unsigned-num (:constant integer))
 676   (:results (result :scs (unsigned-reg)
 677                     :load-if (not (and (sc-is number unsigned-stack)
 678                                        (sc-is result unsigned-stack)
 679                                        (location= number result)))))
 680   (:result-types unsigned-num)
 681   (:note "inline ASH")
 682   (:generator 3
 683     (cond ((and (= amount 1) (not (location= number result)))
 684            (inst lea result (make-ea :qword :index number :scale 2)))
 685           ((and (= amount 2) (not (location= number result)))
 686            (inst lea result (make-ea :qword :index number :scale 4)))
 687           ((and (= amount 3) (not (location= number result)))
 688            (inst lea result (make-ea :qword :index number :scale 8)))
 689           (t
 690            (move result number)
 691            (cond ((< -64 amount 64) ;; XXXX
 692                   ;; this code is used both in ASH and ASH-MOD32, so
 693                   ;; be careful
 694                   (if (plusp amount)
 695                       (inst shl result amount)
 696                       (inst shr result (- amount))))
 697                  (t (if (sc-is result unsigned-reg)
 698                         (inst xor result result)
 699                         (inst mov result 0))))))))
 700
 701 (define-vop (fast-ash-left/signed=>signed)
 702   (:translate ash)
 703   (:args (number :scs (signed-reg) :target result
 704                  :load-if (not (and (sc-is number signed-stack)
 705                                     (sc-is result signed-stack)
 706                                     (location= number result))))
 707          (amount :scs (unsigned-reg) :target ecx))
 708   (:arg-types signed-num positive-fixnum)
 709   (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
 710   (:results (result :scs (signed-reg) :from (:argument 0)
 711                     :load-if (not (and (sc-is number signed-stack)
 712                                        (sc-is result signed-stack)
 713                                        (location= number result)))))
 714   (:result-types signed-num)
 715   (:policy :fast-safe)
 716   (:note "inline ASH")
 717   (:generator 4
 718     (move result number)
 719     (move ecx amount)
 720     (inst shl result :cl)))
 721
 722 (define-vop (fast-ash-left/unsigned=>unsigned)
 723   (:translate ash)
 724   (:args (number :scs (unsigned-reg) :target result
 725                  :load-if (not (and (sc-is number unsigned-stack)
 726                                     (sc-is result unsigned-stack)
 727                                     (location= number result))))
 728          (amount :scs (unsigned-reg) :target ecx))
 729   (:arg-types unsigned-num positive-fixnum)
 730   (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
 731   (:results (result :scs (unsigned-reg) :from (:argument 0)
 732                     :load-if (not (and (sc-is number unsigned-stack)
 733                                        (sc-is result unsigned-stack)
 734                                        (location= number result)))))
 735   (:result-types unsigned-num)
 736   (:policy :fast-safe)
 737   (:note "inline ASH")
 738   (:generator 4
 739     (move result number)
 740     (move ecx amount)
 741     (inst shl result :cl)))
 742
 743 (define-vop (fast-ash/signed=>signed)
 744   (:translate ash)
 745   (:policy :fast-safe)
 746   (:args (number :scs (signed-reg) :target result)
 747          (amount :scs (signed-reg) :target ecx))
 748   (:arg-types signed-num signed-num)
 749   (:results (result :scs (signed-reg) :from (:argument 0)))
 750   (:result-types signed-num)
 751   (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx)
 752   (:note "inline ASH")
 753   (:generator 5
 754     (move result number)
 755     (move ecx amount)
 756     (inst or ecx ecx)
 757     (inst jmp :ns positive)
 758     (inst neg ecx)
 759     (inst cmp ecx 63)
 760     (inst jmp :be okay)
 761     (inst mov ecx 63)
 762     OKAY
 763     (inst sar result :cl)
 764     (inst jmp done)
 765
 766     POSITIVE
 767     ;; The result-type ensures us that this shift will not overflow.
 768     (inst shl result :cl)
 769
 770     DONE))
 771
 772 (define-vop (fast-ash/unsigned=>unsigned)
 773   (:translate ash)
 774   (:policy :fast-safe)
 775   (:args (number :scs (unsigned-reg) :target result)
 776          (amount :scs (signed-reg) :target ecx))
 777   (:arg-types unsigned-num signed-num)
 778   (:results (result :scs (unsigned-reg) :from (:argument 0)))
 779   (:result-types unsigned-num)
 780   (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx)
 781   (:note "inline ASH")
 782   (:generator 5
 783     (move result number)
 784     (move ecx amount)
 785     (inst or ecx ecx)
 786     (inst jmp :ns positive)
 787     (inst neg ecx)
 788     (inst cmp ecx 63)
 789     (inst jmp :be okay)
 790     (inst xor result result)
 791     (inst jmp done)
 792     OKAY
 793     (inst shr result :cl)
 794     (inst jmp done)
 795
 796     POSITIVE
 797     ;; The result-type ensures us that this shift will not overflow.
 798     (inst shl result :cl)
 799
 800     DONE))
 801
 802 (in-package "SB!C")
 803
 804 (defknown %lea (integer integer (member 1 2 4 8 16) (signed-byte 64))
 805   integer
 806   (foldable flushable movable))
 807
 808 (defoptimizer (%lea derive-type) ((base index scale disp))
 809   (when (and (constant-lvar-p scale)
 810              (constant-lvar-p disp))
 811     (let ((scale (lvar-value scale))
 812           (disp (lvar-value disp))
 813           (base-type (lvar-type base))
 814           (index-type (lvar-type index)))
 815       (when (and (numeric-type-p base-type)
 816                  (numeric-type-p index-type))
 817         (let ((base-lo (numeric-type-low base-type))
 818               (base-hi (numeric-type-high base-type))
 819               (index-lo (numeric-type-low index-type))
 820               (index-hi (numeric-type-high index-type)))
 821           (make-numeric-type :class 'integer
 822                              :complexp :real
 823                              :low (when (and base-lo index-lo)
 824                                     (+ base-lo (* index-lo scale) disp))
 825                              :high (when (and base-hi index-hi)
 826                                      (+ base-hi (* index-hi scale) disp))))))))
 827
 828 (defun %lea (base index scale disp)
 829   (+ base (* index scale) disp))
 830
 831 (in-package "SB!VM")
 832
 833 (define-vop (%lea/unsigned=>unsigned)
 834   (:translate %lea)
 835   (:policy :fast-safe)
 836   (:args (base :scs (unsigned-reg))
 837          (index :scs (unsigned-reg)))
 838   (:info scale disp)
 839   (:arg-types unsigned-num unsigned-num
 840               (:constant (member 1 2 4 8))
 841               (:constant (signed-byte 64)))
 842   (:results (r :scs (unsigned-reg)))
 843   (:result-types unsigned-num)
 844   (:generator 5
 845     (inst lea r (make-ea :qword :base base :index index
 846                          :scale scale :disp disp))))
 847
 848 (define-vop (%lea/signed=>signed)
 849   (:translate %lea)
 850   (:policy :fast-safe)
 851   (:args (base :scs (signed-reg))
 852          (index :scs (signed-reg)))
 853   (:info scale disp)
 854   (:arg-types signed-num signed-num
 855               (:constant (member 1 2 4 8))
 856               (:constant (signed-byte 64)))
 857   (:results (r :scs (signed-reg)))
 858   (:result-types signed-num)
 859   (:generator 4
 860     (inst lea r (make-ea :qword :base base :index index
 861                          :scale scale :disp disp))))
 862
 863 (define-vop (%lea/fixnum=>fixnum)
 864   (:translate %lea)
 865   (:policy :fast-safe)
 866   (:args (base :scs (any-reg))
 867          (index :scs (any-reg)))
 868   (:info scale disp)
 869   (:arg-types tagged-num tagged-num
 870               (:constant (member 1 2 4 8))
 871               (:constant (signed-byte 64)))
 872   (:results (r :scs (any-reg)))
 873   (:result-types tagged-num)
 874   (:generator 3
 875     (inst lea r (make-ea :qword :base base :index index
 876                          :scale scale :disp disp))))
 877
 878 ;;; FIXME: before making knowledge of this too public, it needs to be
 879 ;;; fixed so that it's actually _faster_ than the non-CMOV version; at
 880 ;;; least on my Celeron-XXX laptop, this version is marginally slower
 881 ;;; than the above version with branches.  -- CSR, 2003-09-04
 882 (define-vop (fast-cmov-ash/unsigned=>unsigned)
 883   (:translate ash)
 884   (:policy :fast-safe)
 885   (:args (number :scs (unsigned-reg) :target result)
 886          (amount :scs (signed-reg) :target ecx))
 887   (:arg-types unsigned-num signed-num)
 888   (:results (result :scs (unsigned-reg) :from (:argument 0)))
 889   (:result-types unsigned-num)
 890   (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx)
 891   (:temporary (:sc any-reg :from (:eval 0) :to (:eval 1)) zero)
 892   (:note "inline ASH")
 893   (:guard (member :cmov *backend-subfeatures*))
 894   (:generator 4
 895     (move result number)
 896     (move ecx amount)
 897     (inst or ecx ecx)
 898     (inst jmp :ns positive)
 899     (inst neg ecx)
 900     (inst xor zero zero)
 901     (inst shr result :cl)
 902     (inst cmp ecx 63)
 903     (inst cmov :nbe result zero)
 904     (inst jmp done)
 905
 906     POSITIVE
 907     ;; The result-type ensures us that this shift will not overflow.
 908     (inst shl result :cl)
 909
 910     DONE))
 911 \f
 912 ;;; Note: documentation for this function is wrong - rtfm
 913 (define-vop (signed-byte-64-len)
 914   (:translate integer-length)
 915   (:note "inline (signed-byte 32) integer-length")
 916   (:policy :fast-safe)
 917   (:args (arg :scs (signed-reg) :target res))
 918   (:arg-types signed-num)
 919   (:results (res :scs (unsigned-reg)))
 920   (:result-types unsigned-num)
 921   (:generator 28
 922     (move res arg)
 923     (inst cmp res 0)
 924     (inst jmp :ge POS)
 925     (inst not res)
 926     POS
 927     (inst bsr res res)
 928     (inst jmp :z zero)
 929     (inst inc res)
 930     (inst jmp done)
 931     ZERO
 932     (inst xor res res)
 933     DONE))
 934
 935 (define-vop (unsigned-byte-64-len)
 936   (:translate integer-length)
 937   (:note "inline (unsigned-byte 32) integer-length")
 938   (:policy :fast-safe)
 939   (:args (arg :scs (unsigned-reg)))
 940   (:arg-types unsigned-num)
 941   (:results (res :scs (unsigned-reg)))
 942   (:result-types unsigned-num)
 943   (:generator 26
 944     (inst bsr res arg)
 945     (inst jmp :z zero)
 946     (inst inc res)
 947     (inst jmp done)
 948     ZERO
 949     (inst xor res res)
 950     DONE))
 951
 952
 953 (define-vop (unsigned-byte-64-count)
 954   (:translate logcount)
 955   (:note "inline (unsigned-byte 64) logcount")
 956   (:policy :fast-safe)
 957   (:args (arg :scs (unsigned-reg)))
 958   (:arg-types unsigned-num)
 959   (:results (result :scs (unsigned-reg)))
 960   (:result-types positive-fixnum)
 961   (:temporary (:sc unsigned-reg :from (:argument 0)) temp)
 962   (:temporary (:sc unsigned-reg :from (:argument 0)) t1)
 963   (:generator 60
 964     (move result arg)
 965     (move t1 arg)
 966
 967     (inst mov temp result)
 968     (inst shr temp 1)
 969     (inst and result #x55555555)        ; note these masks will restrict the
 970     (inst and temp #x55555555)          ; count to the lower half of arg
 971     (inst add result temp)
 972
 973     (inst mov temp result)
 974     (inst shr temp 2)
 975     (inst and result #x33333333)
 976     (inst and temp #x33333333)
 977     (inst add result temp)
 978
 979     (inst mov temp result)
 980     (inst shr temp 4)
 981     (inst and result #x0f0f0f0f)
 982     (inst and temp #x0f0f0f0f)
 983     (inst add result temp)
 984
 985     (inst mov temp result)
 986     (inst shr temp 8)
 987     (inst and result #x00ff00ff)
 988     (inst and temp #x00ff00ff)
 989     (inst add result temp)
 990
 991     (inst mov temp result)
 992     (inst shr temp 16)
 993     (inst and result #x0000ffff)
 994     (inst and temp #x0000ffff)
 995     (inst add result temp)
 996
 997     ;;; now do the upper half
 998     (inst shr t1 32)
 999
1000     (inst mov temp t1)
1001     (inst shr temp 1)
1002     (inst and t1 #x55555555)
1003     (inst and temp #x55555555)
1004     (inst add t1 temp)
1005
1006     (inst mov temp t1)
1007     (inst shr temp 2)
1008     (inst and t1 #x33333333)
1009     (inst and temp #x33333333)
1010     (inst add t1 temp)
1011
1012     (inst mov temp t1)
1013     (inst shr temp 4)
1014     (inst and t1 #x0f0f0f0f)
1015     (inst and temp #x0f0f0f0f)
1016     (inst add t1 temp)
1017
1018     (inst mov temp t1)
1019     (inst shr temp 8)
1020     (inst and t1 #x00ff00ff)
1021     (inst and temp #x00ff00ff)
1022     (inst add t1 temp)
1023
1024     (inst mov temp t1)
1025     (inst shr temp 16)
1026     (inst and t1 #x0000ffff)
1027     (inst and temp #x0000ffff)
1028     (inst add t1 temp)
1029     (inst add result t1)))
1030
1031
1032 \f
1033 ;;;; binary conditional VOPs
1034
1035 (define-vop (fast-conditional)
1036   (:conditional)
1037   (:info target not-p)
1038   (:effects)
1039   (:affected)
1040   (:policy :fast-safe))
1041
1042 ;;; constant variants are declared for 32 bits not 64 bits, because
1043 ;;; loading a 64 bit constant is silly
1044
1045 (define-vop (fast-conditional/fixnum fast-conditional)
1046   (:args (x :scs (any-reg)
1047             :load-if (not (and (sc-is x control-stack)
1048                                (sc-is y any-reg))))
1049          (y :scs (any-reg control-stack)))
1050   (:arg-types tagged-num tagged-num)
1051   (:note "inline fixnum comparison"))
1052
1053 (define-vop (fast-conditional-c/fixnum fast-conditional/fixnum)
1054   (:args (x :scs (any-reg control-stack)))
1055   (:arg-types tagged-num (:constant (signed-byte 29)))
1056   (:info target not-p y))
1057
1058 (define-vop (fast-conditional/signed fast-conditional)
1059   (:args (x :scs (signed-reg)
1060             :load-if (not (and (sc-is x signed-stack)
1061                                (sc-is y signed-reg))))
1062          (y :scs (signed-reg signed-stack)))
1063   (:arg-types signed-num signed-num)
1064   (:note "inline (signed-byte 32) comparison"))
1065
1066 (define-vop (fast-conditional-c/signed fast-conditional/signed)
1067   (:args (x :scs (signed-reg signed-stack)))
1068   (:arg-types signed-num (:constant (signed-byte 31)))
1069   (:info target not-p y))
1070
1071 (define-vop (fast-conditional/unsigned fast-conditional)
1072   (:args (x :scs (unsigned-reg)
1073             :load-if (not (and (sc-is x unsigned-stack)
1074                                (sc-is y unsigned-reg))))
1075          (y :scs (unsigned-reg unsigned-stack)))
1076   (:arg-types unsigned-num unsigned-num)
1077   (:note "inline (unsigned-byte 32) comparison"))
1078
1079 (define-vop (fast-conditional-c/unsigned fast-conditional/unsigned)
1080   (:args (x :scs (unsigned-reg unsigned-stack)))
1081   (:arg-types unsigned-num (:constant (unsigned-byte 31)))
1082   (:info target not-p y))
1083
1084 (macrolet ((define-conditional-vop (tran cond unsigned not-cond not-unsigned)
1085              `(progn
1086                 ,@(mapcar
1087                    (lambda (suffix cost signed)
1088                      `(define-vop (;; FIXME: These could be done more
1089                                    ;; cleanly with SYMBOLICATE.
1090                                    ,(intern (format nil "~:@(FAST-IF-~A~A~)"
1091                                                     tran suffix))
1092                                    ,(intern
1093                                      (format nil "~:@(FAST-CONDITIONAL~A~)"
1094                                              suffix)))
1095                         (:translate ,tran)
1096                         (:generator ,cost
1097                                     (inst cmp x
1098                                           ,(if (eq suffix '-c/fixnum)
1099                                                '(fixnumize y)
1100                                                'y))
1101                                     (inst jmp (if not-p
1102                                                   ,(if signed
1103                                                        not-cond
1104                                                        not-unsigned)
1105                                                   ,(if signed
1106                                                        cond
1107                                                        unsigned))
1108                                           target))))
1109                    '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned)
1110 ;                  '(/fixnum  /signed  /unsigned)
1111                    '(4 3 6 5 6 5)
1112                    '(t t t t nil nil)))))
1113
1114   (define-conditional-vop < :l :b :ge :ae)
1115   (define-conditional-vop > :g :a :le :be))
1116
1117 (define-vop (fast-if-eql/signed fast-conditional/signed)
1118   (:translate eql)
1119   (:generator 6
1120     (inst cmp x y)
1121     (inst jmp (if not-p :ne :e) target)))
1122
1123 (define-vop (fast-if-eql-c/signed fast-conditional-c/signed)
1124   (:translate eql)
1125   (:generator 5
1126     (cond ((and (sc-is x signed-reg) (zerop y))
1127            (inst test x x))  ; smaller instruction
1128           (t
1129            (inst cmp x y)))
1130     (inst jmp (if not-p :ne :e) target)))
1131
1132 (define-vop (fast-if-eql/unsigned fast-conditional/unsigned)
1133   (:translate eql)
1134   (:generator 6
1135     (inst cmp x y)
1136     (inst jmp (if not-p :ne :e) target)))
1137
1138 (define-vop (fast-if-eql-c/unsigned fast-conditional-c/unsigned)
1139   (:translate eql)
1140   (:generator 5
1141     (cond ((and (sc-is x unsigned-reg) (zerop y))
1142            (inst test x x))  ; smaller instruction
1143           (t
1144            (inst cmp x y)))
1145     (inst jmp (if not-p :ne :e) target)))
1146
1147 ;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a
1148 ;;; known fixnum.
1149
1150 ;;; These versions specify a fixnum restriction on their first arg. We have
1151 ;;; also generic-eql/fixnum VOPs which are the same, but have no restriction on
1152 ;;; the first arg and a higher cost. The reason for doing this is to prevent
1153 ;;; fixnum specific operations from being used on word integers, spuriously
1154 ;;; consing the argument.
1155
1156 (define-vop (fast-eql/fixnum fast-conditional)
1157   (:args (x :scs (any-reg)
1158             :load-if (not (and (sc-is x control-stack)
1159                                (sc-is y any-reg))))
1160          (y :scs (any-reg control-stack)))
1161   (:arg-types tagged-num tagged-num)
1162   (:note "inline fixnum comparison")
1163   (:translate eql)
1164   (:generator 4
1165     (inst cmp x y)
1166     (inst jmp (if not-p :ne :e) target)))
1167 (define-vop (generic-eql/fixnum fast-eql/fixnum)
1168   (:args (x :scs (any-reg descriptor-reg)
1169             :load-if (not (and (sc-is x control-stack)
1170                                (sc-is y any-reg))))
1171          (y :scs (any-reg control-stack)))
1172   (:arg-types * tagged-num)
1173   (:variant-cost 7))
1174
1175
1176 (define-vop (fast-eql-c/fixnum fast-conditional/fixnum)
1177   (:args (x :scs (any-reg control-stack)))
1178   (:arg-types tagged-num (:constant (signed-byte 29)))
1179   (:info target not-p y)
1180   (:translate eql)
1181   (:generator 2
1182     (cond ((and (sc-is x any-reg) (zerop y))
1183            (inst test x x))  ; smaller instruction
1184           (t
1185            (inst cmp x (fixnumize y))))
1186     (inst jmp (if not-p :ne :e) target)))
1187
1188 (define-vop (generic-eql-c/fixnum fast-eql-c/fixnum)
1189   (:args (x :scs (any-reg descriptor-reg control-stack)))
1190   (:arg-types * (:constant (signed-byte 29)))
1191   (:variant-cost 6))
1192 \f
1193 ;;;; 32-bit logical operations
1194
1195 (define-vop (merge-bits)
1196   (:translate merge-bits)
1197   (:args (shift :scs (signed-reg unsigned-reg) :target ecx)
1198          (prev :scs (unsigned-reg) :target result)
1199          (next :scs (unsigned-reg)))
1200   (:arg-types tagged-num unsigned-num unsigned-num)
1201   (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 0)) ecx)
1202   (:results (result :scs (unsigned-reg) :from (:argument 1)))
1203   (:result-types unsigned-num)
1204   (:policy :fast-safe)
1205   (:generator 4
1206     (move ecx shift)
1207     (move result prev)
1208     (inst shrd result next :cl)))
1209
1210 ;;; Only the lower 6 bits of the shift amount are significant.
1211 (define-vop (shift-towards-someplace)
1212   (:policy :fast-safe)
1213   (:args (num :scs (unsigned-reg) :target r)
1214          (amount :scs (signed-reg) :target ecx))
1215   (:arg-types unsigned-num tagged-num)
1216   (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx)
1217   (:results (r :scs (unsigned-reg) :from (:argument 0)))
1218   (:result-types unsigned-num))
1219
1220 (define-vop (shift-towards-start shift-towards-someplace)
1221   (:translate shift-towards-start)
1222   (:note "SHIFT-TOWARDS-START")
1223   (:generator 1
1224     (move r num)
1225     (move ecx amount)
1226     (inst shr r :cl)))
1227
1228 (define-vop (shift-towards-end shift-towards-someplace)
1229   (:translate shift-towards-end)
1230   (:note "SHIFT-TOWARDS-END")
1231   (:generator 1
1232     (move r num)
1233     (move ecx amount)
1234     (inst shl r :cl)))
1235 \f
1236 ;;;; Modular functions
1237
1238 (macrolet ((def (name -c-p)
1239              (let ((fun64 (intern (format nil "~S-MOD64" name)))
1240                    (vopu (intern (format nil "FAST-~S/UNSIGNED=>UNSIGNED" name)))
1241                    (vopcu (intern (format nil "FAST-~S-C/UNSIGNED=>UNSIGNED" name)))
1242                    (vopf (intern (format nil "FAST-~S/FIXNUM=>FIXNUM" name)))
1243                    (vopcf (intern (format nil "FAST-~S-C/FIXNUM=>FIXNUM" name)))
1244                    (vop64u (intern (format nil "FAST-~S-MOD64/UNSIGNED=>UNSIGNED" name)))
1245                    (vop64f (intern (format nil "FAST-~S-MOD64/FIXNUM=>FIXNUM" name)))
1246                    (vop64cu (intern (format nil "FAST-~S-MOD64-C/UNSIGNED=>UNSIGNED" name)))
1247                    (vop64cf (intern (format nil "FAST-~S-MOD64-C/FIXNUM=>FIXNUM" name)))
1248                    (sfun61 (intern (format nil "~S-SMOD61" name)))
1249                    (svop61f (intern (format nil "FAST-~S-SMOD61/FIXNUM=>FIXNUM" name)))
1250                    (svop61cf (intern (format nil "FAST-~S-SMOD61-C/FIXNUM=>FIXNUM" name))))
1251                `(progn
1252                   (define-modular-fun ,fun64 (x y) ,name :unsigned 64)
1253                   (define-modular-fun ,sfun61 (x y) ,name :signed 61)
1254                   (define-vop (,vop64u ,vopu) (:translate ,fun64))
1255                   (define-vop (,vop64f ,vopf) (:translate ,fun64))
1256                   (define-vop (,svop61f ,vopf) (:translate ,sfun61))
1257                   ,@(when -c-p
1258                       `((define-vop (,vop64cu ,vopcu) (:translate ,fun64))
1259                         (define-vop (,svop61cf ,vopcf) (:translate ,sfun61))))))))
1260   (def + t)
1261   (def - t)
1262   ;; (no -C variant as x86 MUL instruction doesn't take an immediate)
1263   (def * nil))
1264
1265 ;;; (no -C variant as x86 MUL instruction doesn't take an immediate)
1266
1267 (define-vop (fast-ash-left-mod64-c/unsigned=>unsigned
1268              fast-ash-c/unsigned=>unsigned)
1269   (:translate ash-left-mod64))
1270 (define-vop (fast-ash-left-mod64/unsigned=>unsigned
1271              fast-ash-left/unsigned=>unsigned))
1272 (deftransform ash-left-mod64 ((integer count)
1273                               ((unsigned-byte 64) (unsigned-byte 6)))
1274   (when (sb!c::constant-lvar-p count)
1275     (sb!c::give-up-ir1-transform))
1276   '(%primitive fast-ash-left-mod64/unsigned=>unsigned integer count))
1277
1278 (define-vop (fast-ash-left-smod61-c/fixnum=>fixnum
1279              fast-ash-c/fixnum=>fixnum)
1280   (:translate ash-left-smod61))
1281 (define-vop (fast-ash-left-smod61/fixnum=>fixnum
1282              fast-ash-left/fixnum=>fixnum))
1283 (deftransform ash-left-smod61 ((integer count)
1284                                ((signed-byte 61) (unsigned-byte 6)))
1285   (when (sb!c::constant-lvar-p count)
1286     (sb!c::give-up-ir1-transform))
1287   '(%primitive fast-ash-left-smod61/fixnum=>fixnum integer count))
1288
1289 (in-package "SB!C")
1290
1291 (defknown sb!vm::%lea-mod64 (integer integer (member 1 2 4 8) (signed-byte 64))
1292   (unsigned-byte 64)
1293   (foldable flushable movable))
1294 (defknown sb!vm::%lea-smod61 (integer integer (member 1 2 4 8) (signed-byte 64))
1295   (signed-byte 61)
1296   (foldable flushable movable))
1297
1298 (define-modular-fun-optimizer %lea ((base index scale disp) :unsigned :width width)
1299   (when (and (<= width 64)
1300              (constant-lvar-p scale)
1301              (constant-lvar-p disp))
1302     (cut-to-width base :unsigned width)
1303     (cut-to-width index :unsigned width)
1304     'sb!vm::%lea-mod64))
1305 (define-modular-fun-optimizer %lea ((base index scale disp) :signed :width width)
1306   (when (and (<= width 61)
1307              (constant-lvar-p scale)
1308              (constant-lvar-p disp))
1309     (cut-to-width base :signed width)
1310     (cut-to-width index :signed width)
1311     'sb!vm::%lea-smod61))
1312
1313 #+sb-xc-host
1314 (progn
1315   (defun sb!vm::%lea-mod64 (base index scale disp)
1316     (ldb (byte 64 0) (%lea base index scale disp)))
1317   (defun sb!vm::%lea-smod61 (base index scale disp)
1318     (mask-signed-field 61 (%lea base index scale disp))))
1319 #-sb-xc-host
1320 (progn
1321   (defun sb!vm::%lea-mod64 (base index scale disp)
1322     (let ((base (logand base #xffffffffffffffff))
1323           (index (logand index #xffffffffffffffff)))
1324       ;; can't use modular version of %LEA, as we only have VOPs for
1325       ;; constant SCALE and DISP.
1326       (ldb (byte 64 0) (+ base (* index scale) disp))))
1327   (defun sb!vm::%lea-smod61 (base index scale disp)
1328     (let ((base (mask-signed-field 61 base))
1329           (index (mask-signed-field 61 index)))
1330       ;; can't use modular version of %LEA, as we only have VOPs for
1331       ;; constant SCALE and DISP.
1332       (mask-signed-field 61 (+ base (* index scale) disp)))))
1333
1334 (in-package "SB!VM")
1335
1336 (define-vop (%lea-mod64/unsigned=>unsigned
1337              %lea/unsigned=>unsigned)
1338   (:translate %lea-mod64))
1339 (define-vop (%lea-smod61/fixnum=>fixnum
1340              %lea/fixnum=>fixnum)
1341   (:translate %lea-smod61))
1342
1343 ;;; logical operations
1344 (define-modular-fun lognot-mod64 (x) lognot :unsigned 64)
1345 (define-vop (lognot-mod64/unsigned=>unsigned)
1346   (:translate lognot-mod64)
1347   (:args (x :scs (unsigned-reg unsigned-stack) :target r
1348             :load-if (not (and (sc-is x unsigned-stack)
1349                                (sc-is r unsigned-stack)
1350                                (location= x r)))))
1351   (:arg-types unsigned-num)
1352   (:results (r :scs (unsigned-reg)
1353                :load-if (not (and (sc-is x unsigned-stack)
1354                                   (sc-is r unsigned-stack)
1355                                   (location= x r)))))
1356   (:result-types unsigned-num)
1357   (:policy :fast-safe)
1358   (:generator 1
1359     (move r x)
1360     (inst not r)))
1361
1362 (define-modular-fun logxor-mod64 (x y) logxor :unsigned 64)
1363 (define-vop (fast-logxor-mod64/unsigned=>unsigned
1364              fast-logxor/unsigned=>unsigned)
1365   (:translate logxor-mod64))
1366 (define-vop (fast-logxor-mod64-c/unsigned=>unsigned
1367              fast-logxor-c/unsigned=>unsigned)
1368   (:translate logxor-mod64))
1369 (define-vop (fast-logxor-mod64/fixnum=>fixnum
1370              fast-logxor/fixnum=>fixnum)
1371   (:translate logxor-mod64))
1372 (define-vop (fast-logxor-mod64-c/fixnum=>fixnum
1373              fast-logxor-c/fixnum=>fixnum)
1374   (:translate logxor-mod64))
1375
1376 (define-source-transform logeqv (&rest args)
1377   (if (oddp (length args))
1378       `(logxor ,@args)
1379       `(lognot (logxor ,@args))))
1380 (define-source-transform logandc1 (x y)
1381   `(logand (lognot ,x) ,y))
1382 (define-source-transform logandc2 (x y)
1383   `(logand ,x (lognot ,y)))
1384 (define-source-transform logorc1 (x y)
1385   `(logior (lognot ,x) ,y))
1386 (define-source-transform logorc2 (x y)
1387   `(logior ,x (lognot ,y)))
1388 (define-source-transform lognor (x y)
1389   `(lognot (logior ,x ,y)))
1390 (define-source-transform lognand (x y)
1391   `(lognot (logand ,x ,y)))
1392 \f
1393 ;;;; bignum stuff
1394
1395 (define-vop (bignum-length get-header-data)
1396   (:translate sb!bignum:%bignum-length)
1397   (:policy :fast-safe))
1398
1399 (define-vop (bignum-set-length set-header-data)
1400   (:translate sb!bignum:%bignum-set-length)
1401   (:policy :fast-safe))
1402
1403 (define-full-reffer bignum-ref * bignum-digits-offset other-pointer-lowtag
1404   (unsigned-reg) unsigned-num sb!bignum:%bignum-ref)
1405
1406 (define-full-setter bignum-set * bignum-digits-offset other-pointer-lowtag
1407   (unsigned-reg) unsigned-num sb!bignum:%bignum-set)
1408
1409 (define-vop (digit-0-or-plus)
1410   (:translate sb!bignum:%digit-0-or-plusp)
1411   (:policy :fast-safe)
1412   (:args (digit :scs (unsigned-reg)))
1413   (:arg-types unsigned-num)
1414   (:conditional)
1415   (:info target not-p)
1416   (:generator 3
1417     (inst or digit digit)
1418     (inst jmp (if not-p :s :ns) target)))
1419
1420
1421 ;;; For add and sub with carry the sc of carry argument is any-reg so
1422 ;;; the it may be passed as a fixnum or word and thus may be 0, 1, or
1423 ;;; 4. This is easy to deal with and may save a fixnum-word
1424 ;;; conversion.
1425 (define-vop (add-w/carry)
1426   (:translate sb!bignum:%add-with-carry)
1427   (:policy :fast-safe)
1428   (:args (a :scs (unsigned-reg) :target result)
1429          (b :scs (unsigned-reg unsigned-stack) :to :eval)
1430          (c :scs (any-reg) :target temp))
1431   (:arg-types unsigned-num unsigned-num positive-fixnum)
1432   (:temporary (:sc any-reg :from (:argument 2) :to :eval) temp)
1433   (:results (result :scs (unsigned-reg) :from (:argument 0))
1434             (carry :scs (unsigned-reg)))
1435   (:result-types unsigned-num positive-fixnum)
1436   (:generator 4
1437     (move result a)
1438     (move temp c)
1439     (inst neg temp) ; Set the carry flag to 0 if c=0 else to 1
1440     (inst adc result b)
1441     (inst mov carry 0)
1442     (inst adc carry carry)))
1443
1444 ;;; Note: the borrow is the oppostite of the x86 convention - 1 for no
1445 ;;; borrow and 0 for a borrow.
1446 (define-vop (sub-w/borrow)
1447   (:translate sb!bignum:%subtract-with-borrow)
1448   (:policy :fast-safe)
1449   (:args (a :scs (unsigned-reg) :to :eval :target result)
1450          (b :scs (unsigned-reg unsigned-stack) :to :result)
1451          (c :scs (any-reg control-stack)))
1452   (:arg-types unsigned-num unsigned-num positive-fixnum)
1453   (:results (result :scs (unsigned-reg) :from :eval)
1454             (borrow :scs (unsigned-reg)))
1455   (:result-types unsigned-num positive-fixnum)
1456   (:generator 5
1457     (inst cmp c 1) ; Set the carry flag to 1 if c=0 else to 0
1458     (move result a)
1459     (inst sbb result b)
1460     (inst mov borrow 0)
1461     (inst adc borrow borrow)
1462     (inst xor borrow 1)))
1463
1464
1465 (define-vop (bignum-mult-and-add-3-arg)
1466   (:translate sb!bignum:%multiply-and-add)
1467   (:policy :fast-safe)
1468   (:args (x :scs (unsigned-reg) :target eax)
1469          (y :scs (unsigned-reg unsigned-stack))
1470          (carry-in :scs (unsigned-reg unsigned-stack)))
1471   (:arg-types unsigned-num unsigned-num unsigned-num)
1472   (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
1473                    :to (:result 1) :target lo) eax)
1474   (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
1475                    :to (:result 0) :target hi) edx)
1476   (:results (hi :scs (unsigned-reg))
1477             (lo :scs (unsigned-reg)))
1478   (:result-types unsigned-num unsigned-num)
1479   (:generator 20
1480     (move eax x)
1481     (inst mul eax y)
1482     (inst add eax carry-in)
1483     (inst adc edx 0)
1484     (move hi edx)
1485     (move lo eax)))
1486
1487 (define-vop (bignum-mult-and-add-4-arg)
1488   (:translate sb!bignum:%multiply-and-add)
1489   (:policy :fast-safe)
1490   (:args (x :scs (unsigned-reg) :target eax)
1491          (y :scs (unsigned-reg unsigned-stack))
1492          (prev :scs (unsigned-reg unsigned-stack))
1493          (carry-in :scs (unsigned-reg unsigned-stack)))
1494   (:arg-types unsigned-num unsigned-num unsigned-num unsigned-num)
1495   (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
1496                    :to (:result 1) :target lo) eax)
1497   (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
1498                    :to (:result 0) :target hi) edx)
1499   (:results (hi :scs (unsigned-reg))
1500             (lo :scs (unsigned-reg)))
1501   (:result-types unsigned-num unsigned-num)
1502   (:generator 20
1503     (move eax x)
1504     (inst mul eax y)
1505     (inst add eax prev)
1506     (inst adc edx 0)
1507     (inst add eax carry-in)
1508     (inst adc edx 0)
1509     (move hi edx)
1510     (move lo eax)))
1511
1512
1513 (define-vop (bignum-mult)
1514   (:translate sb!bignum:%multiply)
1515   (:policy :fast-safe)
1516   (:args (x :scs (unsigned-reg) :target eax)
1517          (y :scs (unsigned-reg unsigned-stack)))
1518   (:arg-types unsigned-num unsigned-num)
1519   (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
1520                    :to (:result 1) :target lo) eax)
1521   (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
1522                    :to (:result 0) :target hi) edx)
1523   (:results (hi :scs (unsigned-reg))
1524             (lo :scs (unsigned-reg)))
1525   (:result-types unsigned-num unsigned-num)
1526   (:generator 20
1527     (move eax x)
1528     (inst mul eax y)
1529     (move hi edx)
1530     (move lo eax)))
1531
1532 (define-vop (bignum-lognot lognot-mod64/unsigned=>unsigned)
1533   (:translate sb!bignum:%lognot))
1534
1535 (define-vop (fixnum-to-digit)
1536   (:translate sb!bignum:%fixnum-to-digit)
1537   (:policy :fast-safe)
1538   (:args (fixnum :scs (any-reg control-stack) :target digit))
1539   (:arg-types tagged-num)
1540   (:results (digit :scs (unsigned-reg)
1541                    :load-if (not (and (sc-is fixnum control-stack)
1542                                       (sc-is digit unsigned-stack)
1543                                       (location= fixnum digit)))))
1544   (:result-types unsigned-num)
1545   (:generator 1
1546     (move digit fixnum)
1547     (inst sar digit 3)))
1548
1549 (define-vop (bignum-floor)
1550   (:translate sb!bignum:%floor)
1551   (:policy :fast-safe)
1552   (:args (div-high :scs (unsigned-reg) :target edx)
1553          (div-low :scs (unsigned-reg) :target eax)
1554          (divisor :scs (unsigned-reg unsigned-stack)))
1555   (:arg-types unsigned-num unsigned-num unsigned-num)
1556   (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 1)
1557                    :to (:result 0) :target quo) eax)
1558   (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 0)
1559                    :to (:result 1) :target rem) edx)
1560   (:results (quo :scs (unsigned-reg))
1561             (rem :scs (unsigned-reg)))
1562   (:result-types unsigned-num unsigned-num)
1563   (:generator 300
1564     (move edx div-high)
1565     (move eax div-low)
1566     (inst div eax divisor)
1567     (move quo eax)
1568     (move rem edx)))
1569
1570 (define-vop (signify-digit)
1571   (:translate sb!bignum:%fixnum-digit-with-correct-sign)
1572   (:policy :fast-safe)
1573   (:args (digit :scs (unsigned-reg unsigned-stack) :target res))
1574   (:arg-types unsigned-num)
1575   (:results (res :scs (any-reg signed-reg)
1576                  :load-if (not (and (sc-is digit unsigned-stack)
1577                                     (sc-is res control-stack signed-stack)
1578                                     (location= digit res)))))
1579   (:result-types signed-num)
1580   (:generator 1
1581     (move res digit)
1582     (when (sc-is res any-reg control-stack)
1583       (inst shl res 3))))
1584
1585 (define-vop (digit-ashr)
1586   (:translate sb!bignum:%ashr)
1587   (:policy :fast-safe)
1588   (:args (digit :scs (unsigned-reg unsigned-stack) :target result)
1589          (count :scs (unsigned-reg) :target ecx))
1590   (:arg-types unsigned-num positive-fixnum)
1591   (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
1592   (:results (result :scs (unsigned-reg) :from (:argument 0)
1593                     :load-if (not (and (sc-is result unsigned-stack)
1594                                        (location= digit result)))))
1595   (:result-types unsigned-num)
1596   (:generator 1
1597     (move result digit)
1598     (move ecx count)
1599     (inst sar result :cl)))
1600
1601 (define-vop (digit-lshr digit-ashr)
1602   (:translate sb!bignum:%digit-logical-shift-right)
1603   (:generator 1
1604     (move result digit)
1605     (move ecx count)
1606     (inst shr result :cl)))
1607
1608 (define-vop (digit-ashl digit-ashr)
1609   (:translate sb!bignum:%ashl)
1610   (:generator 1
1611     (move result digit)
1612     (move ecx count)
1613     (inst shl result :cl)))
1614 \f
1615 ;;;; static functions
1616
1617 (define-static-fun two-arg-/ (x y) :translate /)
1618
1619 (define-static-fun two-arg-gcd (x y) :translate gcd)
1620 (define-static-fun two-arg-lcm (x y) :translate lcm)
1621
1622 (define-static-fun two-arg-and (x y) :translate logand)
1623 (define-static-fun two-arg-ior (x y) :translate logior)
1624 (define-static-fun two-arg-xor (x y) :translate logxor)
1625
1626
1627 (in-package "SB!C")
1628
1629 (defun *-transformer (y)
1630   (cond
1631     ((= y (ash 1 (integer-length y)))
1632      ;; there's a generic transform for y = 2^k
1633      (give-up-ir1-transform))
1634     ((member y '(3 5 9))
1635      ;; we can do these multiplications directly using LEA
1636      `(%lea x x ,(1- y) 0))
1637     (t
1638      ;; A normal 64-bit multiplication takes 4 cycles on Athlon 64/Opteron.
1639      ;; Optimizing multiplications (other than the above cases) to
1640      ;; shifts/adds/leas gives a maximum improvement of 1 cycle, but requires
1641      ;; quite a lot of hairy code.
1642      (give-up-ir1-transform))))
1643
1644 (deftransform * ((x y)
1645                  ((unsigned-byte 64) (constant-arg (unsigned-byte 64)))
1646                  (unsigned-byte 64))
1647   "recode as leas, shifts and adds"
1648   (let ((y (lvar-value y)))
1649     (*-transformer y)))
1650 (deftransform sb!vm::*-mod64
1651     ((x y) ((unsigned-byte 64) (constant-arg (unsigned-byte 64)))
1652      (unsigned-byte 64))
1653   "recode as leas, shifts and adds"
1654   (let ((y (lvar-value y)))
1655     (*-transformer y)))
1656
1657 (deftransform * ((x y)
1658                  ((signed-byte 61) (constant-arg (unsigned-byte 64)))
1659                  (signed-byte 61))
1660   "recode as leas, shifts and adds"
1661   (let ((y (lvar-value y)))
1662     (*-transformer y)))
1663 (deftransform sb!vm::*-smod61
1664     ((x y) ((signed-byte 61) (constant-arg (unsigned-byte 64)))
1665      (signed-byte 61))
1666   "recode as leas, shifts and adds"
1667   (let ((y (lvar-value y)))
1668     (*-transformer y)))