src/compiler/x86-64/arith.lisp

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