;;;; the VM definition of arithmetic VOPs for the x86-64

;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.

(in-package "SB-VM")


;;; For data collection so we can decide what to store in +POPULAR-RAW-CONSTANTS+.
(defvar *raw-const-histogram* nil)
;; Return either a RIP-relative or NULL-TN-relative EA to the bits of X, disregarding sign.
(defun ref-shared-qword-literal (x)
  ;; Since X might be a signed-word that is = to some unsigned word in memory,
  ;; compare the bit representation, not the logical value.
  (let ((x (ldb (byte 64 0) x)))
    ;; Initially I wanted to sink this logic of sharing +POPULAR-RAW-CONSTANTS+
    ;; into REGISTER-INLINE-CONSTANT. However, REGISTER-INLINE-CONSTANT can be used to
    ;; reference a _mutable_ raw word. An example occurs in SEH-TRAMPOLINE where the
    ;; bits dumped happen to be -1 but are irrelevant - it is merely reserving a word in
    ;; the unboxed data section of the asm code. I would not want that to accidentally
    ;; see a match in +POPULAR-RAW-CONSTANTS+ (though in fact -1 is not in there).
    ;; The perceived problem is mainly theoretical, but some benefit stems from
    ;; having this wrapper function nonetheless.
    #+nil (let ((c (assoc x *raw-const-histogram*)))
            (if c (incf (cdr c)) (push (cons x 1) *raw-const-histogram*)))
    (acond ((position x +popular-raw-constants+)
            (ea (- (* (+ symbol-size it) n-word-bytes) t-nil-offset other-pointer-lowtag)
                null-tn))
           (t
            (register-inline-constant :qword x)))))
;; If 'plausible-signed-imm32-operand-p' is true, use it; otherwise use a RIP-relative constant
;; or possibly return the NIL-based address of one of +POPULAR-RAW-CONSTANTS+
(defun constantize (x)
  (awhen (plausible-signed-imm32-operand-p x)
    (return-from constantize it))
  (ref-shared-qword-literal x))

;;;; unary operations

(define-vop (fast-safe-arith-op)
  (:policy :fast-safe))

(define-vop (fixnum-unop fast-safe-arith-op)
  (:args (x :scs (any-reg control-stack) :target res))
  (:results (res :scs (any-reg control-stack)))
  (:temporary (:sc unsigned-reg) temp)
  (:note "inline fixnum arithmetic")
  (:arg-types tagged-num)
  (:result-types tagged-num))

(define-vop (signed-unop fast-safe-arith-op)
  (:args (x :scs (signed-reg signed-stack) :target res))
  (:results (res :scs (signed-reg signed-stack)))
  (:temporary (:sc unsigned-reg) temp)
  (:note "inline (signed-byte 64) arithmetic")
  (:arg-types signed-num)
  (:result-types signed-num))

;;; logical or arithmetic negation
(defun emit-inline-neg (op arg result temp vop &optional fixnump)
  (declare (ignore vop))
  ;; If ARG and RESULT are the same location, then the initial and final MOVEs
  ;; are both no-ops. If different locations and not both memory,
  ;; then the initial move is a physical move and the final is a no-op.
  ;; If both are stack locations, then compute the answer in temp.
  ;; (REG might be a stack location, not necessarily a GPR in this emitter.
  ;; It's just a naming convention that is consistent with other emitters)
  (let ((reg (if (or (alias-p arg result) (gpr-tn-p arg) (gpr-tn-p result))
                 result
                 temp)))
    (move reg arg)
    (case op
      (not (if fixnump (inst xor reg (fixnumize -1)) (inst not reg)))
      (neg (inst neg reg)))
    (move result reg)))

(define-vop (fast-negate/fixnum fixnum-unop)
  (:translate %negate)
  (:vop-var vop)
  (:generator 1 (emit-inline-neg 'neg x res temp vop)))

(define-vop (fast-negate/signed signed-unop)
  (:translate %negate)
  (:vop-var vop)
  (:generator 2 (emit-inline-neg 'neg x res temp vop)))

(define-vop (fast-negate/unsigned signed-unop)
  (:args (x :scs (unsigned-reg unsigned-stack) :target res))
  (:arg-types unsigned-num)
  (:translate %negate)
  (:vop-var vop)
  (:generator 3 (emit-inline-neg 'neg x res temp vop)))

(define-vop (fast-negate/signed-unsigned signed-unop)
  (:results (res :scs (unsigned-reg unsigned-stack)))
  (:result-types unsigned-num)
  (:translate %negate)
  (:vop-var vop)
  (:generator 3 (emit-inline-neg 'neg x res temp vop)))

(define-vop (fast-lognot/fixnum fixnum-unop)
  (:translate lognot)
  (:vop-var vop)
  (:generator 1 (emit-inline-neg 'not x res temp vop t)))

(define-vop (fast-lognot/signed signed-unop)
  (:translate lognot)
  (:vop-var vop)
  (:generator 2 (emit-inline-neg 'not x res temp vop nil)))

;;;; binary fixnum operations

;;; Assume that any constant operand is the second arg...

(define-vop (fast-fixnum-binop fast-safe-arith-op)
  (:args (x :target r :scs (any-reg)
            :load-if (not (and (sc-is x control-stack)
                               (sc-is y any-reg)
                               (sc-is r control-stack)
                               (location= x r))))
         (y :scs (any-reg control-stack)))
  (:arg-types tagged-num tagged-num)
  (:results (r :scs (any-reg) :from (:argument 0)
               :load-if (not (and (sc-is x control-stack)
                                  (sc-is y any-reg)
                                  (sc-is r control-stack)
                                  (location= x r)))))
  (:result-types tagged-num)
  (:note "inline fixnum arithmetic"))

(define-vop (fast-unsigned-binop fast-safe-arith-op)
  (:args (x :target r :scs (unsigned-reg)
            :load-if (not (and (sc-is x unsigned-stack)
                               (sc-is y unsigned-reg)
                               (sc-is r unsigned-stack)
                               (location= x r))))
         (y :scs (unsigned-reg unsigned-stack)))
  (:arg-types unsigned-num unsigned-num)
  (:results (r :scs (unsigned-reg) :from (:argument 0)
            :load-if (not (and (sc-is x unsigned-stack)
                               (sc-is y unsigned-reg)
                               (sc-is r unsigned-stack)
                               (location= x r)))))
  (:result-types unsigned-num)
  (:note "inline (unsigned-byte 64) arithmetic"))

(define-vop (fast-signed-binop fast-safe-arith-op)
  (:args (x :target r :scs (signed-reg)
            :load-if (not (and (sc-is x signed-stack)
                               (sc-is y signed-reg)
                               (sc-is r signed-stack)
                               (location= x r))))
         (y :scs (signed-reg signed-stack)))
  (:arg-types signed-num signed-num)
  (:results (r :scs (signed-reg) :from (:argument 0)
            :load-if (not (and (sc-is x signed-stack)
                               (sc-is y signed-reg)
                               (sc-is r signed-stack)
                               (location= x r)))))
  (:result-types signed-num)
  (:note "inline (signed-byte 64) arithmetic"))

(define-vop (fast-fixnum-binop-c fast-safe-arith-op)
  (:args (x :target r :scs (any-reg) :load-if t))
  (:info y)
  (:arg-types tagged-num (:constant fixnum))
  (:results (r :scs (any-reg) :load-if t))
  (:result-types tagged-num)
  (:note "inline fixnum arithmetic"))

(define-vop (fast-unsigned-binop-c fast-safe-arith-op)
  (:args (x :target r :scs (unsigned-reg) :load-if t))
  (:info y)
  (:arg-types unsigned-num (:constant (unsigned-byte 64)))
  (:results (r :scs (unsigned-reg) :load-if t))
  (:result-types unsigned-num)
  (:note "inline (unsigned-byte 64) arithmetic"))

(define-vop (fast-signed-binop-c fast-safe-arith-op)
  (:args (x :target r :scs (signed-reg) :load-if t))
  (:info y)
  (:arg-types signed-num (:constant (signed-byte 64)))
  (:results (r :scs (signed-reg) :load-if t))
  (:result-types signed-num)
  (:note "inline (signed-byte 64) arithmetic"))

(macrolet ((define-binop (translate untagged-penalty op
                          &key fixnum=>fixnum c/fixnum=>fixnum
                               signed=>signed c/signed=>signed
                               unsigned=>unsigned c/unsigned=>unsigned)

             `(progn
                (define-vop (,(symbolicate "FAST-" translate "/FIXNUM=>FIXNUM")
                             fast-fixnum-binop)
                  (:translate ,translate)
                  (:generator 2
                   ,@(or fixnum=>fixnum `((move r x) (inst ,op r y)))))
                (define-vop (,(symbolicate 'fast- translate '-c/fixnum=>fixnum)
                             fast-fixnum-binop-c)
                  (:arg-refs x-ref)
                  (:translate ,translate)
                  (:generator 1
                   ,@(or c/fixnum=>fixnum
                         `((move r x) (inst ,op r (constantize (fixnumize y)))))))
                (define-vop (,(symbolicate "FAST-" translate "/SIGNED=>SIGNED")
                             fast-signed-binop)
                  (:translate ,translate)
                  (:generator ,(1+ untagged-penalty)
                   ,@(or signed=>signed `((move r x) (inst ,op r y)))))
                (define-vop (,(symbolicate 'fast- translate '-c/signed=>signed)
                             fast-signed-binop-c)
                  (:translate ,translate)
                  (:generator ,untagged-penalty
                   ,@(or c/signed=>signed `((move r x) (inst ,op r (constantize y))))))
                (define-vop (,(symbolicate "FAST-"
                                           translate
                                           "/UNSIGNED=>UNSIGNED")
                             fast-unsigned-binop)
                  (:translate ,translate)
                  (:generator ,(1+ untagged-penalty)
                   ,@(or unsigned=>unsigned `((move r x) (inst ,op r y)))))
                (define-vop (,(symbolicate 'fast-
                                           translate
                                           '-c/unsigned=>unsigned)
                             fast-unsigned-binop-c)
                  (:translate ,translate)
                  (:generator ,untagged-penalty
                   ,@(or c/unsigned=>unsigned
                         `((move r x) (inst ,op r (constantize y)))))))))

  ;; The following have microoptimizations for some special cases
  ;; not caught by the front end.

  (define-binop logand 2 and
    :c/fixnum=>fixnum
    ;; Use :dword size if the constant is (unsigned-byte 32) and destination
    ;; is a GPR; the high 32 bits get automatically zeroed.
    ((let ((y (fixnumize y))
           (gpr-r-p (gpr-tn-p r)))
       (cond ((and gpr-r-p
                   (eql y (logandc2 (1- (expt 2 32)) fixnum-tag-mask)))
              (inst mov :dword r x))
             ((and gpr-r-p
                   (eql y (logandc2 (1- (expt 2 16)) fixnum-tag-mask)))
              (inst movzx '(:word :dword) r x))
             ((and gpr-r-p
                   (eql y (logandc2 (1- (expt 2 8)) fixnum-tag-mask)))
              (inst movzx '(:byte :dword) r x))
             ((and (gpr-tn-p x) (typep y '(unsigned-byte 32)))
              ;; A 32-bit mov suffices unless to memory.
              (unless (location= x r)
                (inst mov (if gpr-r-p :dword :qword) r x))
              (inst and :dword r y))
             ((and (not (plausible-signed-imm32-operand-p y))
                   (let* ((int (sb-c::type-approximate-interval (tn-ref-type x-ref)))
                          (mask (logandc1 (logior y fixnum-tag-mask)
                                          (ldb (byte (+ (integer-length (sb-c::interval-high int)) n-fixnum-tag-bits) 0) -1))))
                     (when (and (>= (sb-c::interval-low int) 0)
                                (= (logcount mask) 1))
                       (move r x)
                       (inst btr r (1- (integer-length mask)))
                       t))))
             (t
              (move r x)
              (inst and r (constantize y))))))
    :c/unsigned=>unsigned
    ((let ((gpr-r-p (gpr-tn-p r)))
       (cond ((eql y most-positive-word)
              (move r x))
             ((and gpr-r-p
                   (eql y (1- (expt 2 32))))
              (inst mov :dword r x))
             ((and gpr-r-p
                   (eql y (1- (expt 2 16))))
              (inst movzx '(:word :dword) r x))
             ((and gpr-r-p
                   (eql y (1- (expt 2 8))))
              (inst movzx '(:byte :dword) r x))
             ((and (not (plausible-signed-imm32-operand-p y))
                   (= (logcount (logandc1 y most-positive-word)) 1))
              (move r x)
              (inst btr r (1- (integer-length (logandc1 y most-positive-word)))))
             (t
              (move r x)
              (inst and r (constantize y))))))
    :c/signed=>signed
    ((let ((gpr-r-p (gpr-tn-p r)))
       (cond ((and gpr-r-p
                   (eql y (1- (expt 2 32))))
              (inst mov :dword r x))
             ((and gpr-r-p
                   (eql y (1- (expt 2 16))))
              (inst movzx '(:word :dword) r x))
             ((and gpr-r-p
                   (eql y (1- (expt 2 8))))
              (inst movzx '(:byte :dword) r x))
             ((and (not (plausible-signed-imm32-operand-p y))
                   (= (logcount (logandc1 y most-positive-word)) 1))
              (move r x)
              (inst btr r (1- (integer-length (logandc1 y most-positive-word)))))
             (t
              (move r x)
              (inst and r (constantize y)))))))

  (define-binop logior 2 or
    :c/fixnum=>fixnum
    ((let ((y (fixnumize y)))
       (move r x)
       (cond ((and (not (plausible-signed-imm32-operand-p y))
                   (= (logcount y) 1))
              (inst bts r (1- (integer-length y))))
             (t
              (inst or r (constantize y))))))
    :c/unsigned=>unsigned
    ((cond ((and (gpr-tn-p r) (eql y -1)) ; special-case "OR reg, all-ones"
            ;; I have yet to elicit this case. Can it happen?
            (inst mov r -1))
           ((and (not (plausible-signed-imm32-operand-p y))
                 (= (logcount y) 1))
            (move r x)
            (inst bts r (1- (integer-length y))))
           (t
            (move r x)
            (inst or r (constantize y)))))
    :c/signed=>signed
    ((move r x)
     (cond ((and (not (plausible-signed-imm32-operand-p y))
                 (= (logcount (ldb (byte n-word-bits 0) y)) 1))
            (inst bts r (1- (integer-length (ldb (byte n-word-bits 0) y)))))
           (t
            (inst or r (constantize y))))))

  (define-binop logxor 2 xor
    :c/unsigned=>unsigned
    ((move r x)
     (let ((y (constantize y)))
       (if (eql y -1) ; special-case "XOR reg, [all-ones]"
           (inst not r)
           (inst xor r y))))))

(define-vop (fast-logior-unsigned-signed=>signed fast-safe-arith-op)
  (:args (x :scs (unsigned-reg) :to (:result 1))
         (y :target r :scs (signed-reg)))
  (:arg-types unsigned-num signed-num)
  (:results (r :scs (signed-reg)))
  (:result-types signed-num)
  (:note "inline (unsigned-byte 64) arithmetic")
  (:translate logior)
  (:generator 3
    (move r y)
    (inst or r x)))

(define-vop (fast-logior-signed-unsigned=>signed fast-safe-arith-op)
  (:args (x :target r :scs (signed-reg))
         (y :scs (unsigned-reg)))
  (:arg-types signed-num unsigned-num)
  (:results (r :scs (signed-reg) :from (:argument 0)))
  (:result-types signed-num)
  (:note "inline (unsigned-byte 64) arithmetic")
  (:translate logior)
  (:generator 3
    (move r x)
    (inst or r y)))

(defun prepare-alu-operands (x y vop const-tn-xform commutative)
  (let ((arg (vop-args vop)))
    ;; (when (tn-ref-load-tn arg)
    ;;   (bug "Shouldn't have a load TN for arg0"))
    (let ((arg (tn-ref-across arg)))
      (when (and arg (tn-ref-load-tn arg))
        (bug "Shouldn't have a load TN for arg1"))))
  (let ((res (vop-results vop)))
    (when (tn-ref-load-tn res) (bug "Shouldn't have a load TN for result")))
  ;; Immediates won't be loaded since the :LOAD-IF expression is NIL.
  ;; Such value should always be placed into Y if the operation is +.
  ;; And note that because we're forgoing the automatic arg loading,
  ;; any fixnum scaling that would have happened automatically won't.
  (when (and (tn-p x) (sc-is x immediate))
    (setq x (funcall const-tn-xform (tn-value x))))
  (when (and (tn-p y) (sc-is y immediate))
    (setq y (funcall const-tn-xform (tn-value y))))
  (when (and commutative (integerp x))
    (rotatef x y)) ; weird! why did IR1 not flip the args?
  (values x y))

(defun emit-inline-smul (op x y result temp vop dummy taggedp) ; signed multiply
  (declare (ignore op dummy))
  (multiple-value-setq (x y) (prepare-alu-operands x y vop 'identity t))
  (aver (not (integerp x)))
  (let ((constant-y (integerp y))) ; don't need to unscale Y if true
    (when (and constant-y (not (typep y '(signed-byte 32))))
      (setq y (ref-shared-qword-literal y)))
    (let ((reg (if (gpr-tn-p result) result temp)))
      (cond ((integerp y)
             (inst imul reg x y))
            ((alias-p reg y)
             (when taggedp
               (inst sar reg n-fixnum-tag-bits))
             (inst imul reg x)
             ;; If all operands are LOCATION= then both args got unfixnumized
             ;; by the preceding SAR, so re-fixnumize the result.
             (when (and (alias-p reg x) taggedp)
               (inst shl reg n-fixnum-tag-bits)))
            (t
             (move reg x) ; this can't clobber Y
             (when (and (not constant-y) taggedp)
               (inst sar reg n-fixnum-tag-bits))
             (inst imul reg y)))
      (move result reg))))

;;; Special handling of add on the x86; can sometimes use lea to avoid a
;;; register move, otherwise it uses add.
;;;
;;; This should more-or-less be the general skeleton for any two-operand
;;; arithmetic vop in terms of the case-by-case analysis for where the result
;;; is going.
;;; Non-commutative operations (notably SUB) need a little extra care.
;;; MUL is also a bit different due to asymmetry of the instruction.
(defun emit-inline-add-sub (op x y result temp vop const-tn-xform)
  (declare (type (member add sub) op))
  (multiple-value-setq (x y) (prepare-alu-operands x y vop const-tn-xform (eq op 'add)))

  (when (and (typep y 'unsigned-byte)
             (logbitp (1- n-word-bits) y))
    ;; Turn unsigned constants into smaller negative constants
    (case op
      (add
       (setf op 'sub
             y (- (sb-c::mask-signed-field n-word-bits y))))
      (sub
       (setf op 'add
             y (- (sb-c::mask-signed-field n-word-bits y))))))
  (cond ((and (eq op 'sub) (and (integerp y) (not (eql y (ash -1 31)))))
         ;; If Y is -2147483648 then the negation is not (signed-byte 32).
         (setq op 'add y (- y)))
        ((and (eq op 'add) (eql y (ash 1 31)))
         (setq op 'sub y (- y))))

  ;; Oversized integers need to become RIP-relative constants
  (when (integerp x) (setq x (constantize x)))
  (when (integerp y) (setq y (constantize y)))

  (let* ((y-is-reg-or-imm32 (or (gpr-tn-p y) (typep y '(signed-byte 32))))
         (commutative (eq op 'add)))
      (when (alias-p result x)
        ;; the first two clauses are correct because if the instruction was SUB with
        ;; an immediate then it got turned into ADD with the negation of the immediate.
        (cond ((eql y -1) (inst dec x))
              ((eql y +1) (inst inc x))
              ((or (gpr-tn-p x) y-is-reg-or-imm32)
               ;; At most one memory operand. Result could be memory or register.
               (inst* op x y))
              (t ; two memory operands: X is not a GPR, Y is neither GPR nor immm
               (inst mov temp y)
               (inst* op x temp)))
        (return-from emit-inline-add-sub))
      (when (and (alias-p result y) commutative)
        ;; Result in the same location as Y can happen because we no longer specify
        ;; that RESULT is live from (:ARGUMENT 0).
        (cond ((or (gpr-tn-p x) (gpr-tn-p y))
               (inst* op y x))
              (t
               (inst mov temp x)
               (inst* op y temp)))
        (return-from emit-inline-add-sub))
      (let ((reg (if (and (gpr-tn-p result)
                          ;; If Y aliases RESULT in SUB, then an initial (move reg x)
                          ;; could clobber Y.
                          (or commutative (not (alias-p result y))))
                     result
                     temp)))
        (cond ((and (eq op 'add) ; LEA can't do subtraction
                    (gpr-tn-p x) y-is-reg-or-imm32) ; register + (register | imm32)
               (inst lea reg (if (fixnump y) (ea y x) (ea x y))))
              (t
               ;; If commutative, then neither X nor Y is an alias of RESULT.
               ;; If non-commutative, then RESULT could be Y, in which case REG is
               ;; TEMP so that we don't trash Y by moving X into it.
               (inst mov reg x)
               (cond ((and (eq op 'add) (eql y 1)) (inst inc reg))
                     ((and (eq op 'add) (eql y -1)) (inst dec reg))
                     (t (inst* op reg y)))))
        (move result reg))))

;;; FIXME: we shouldn't need 12 variants, plus the modular variants, for what should
;;; be 1 vop. Certainly + and - can be done by one vop which examines lvar-fun-name.
;;; And the "/c" (constant 2nd arg) vops can be removed since there is no extra register
;;; consumed anyway. When I tried to do those simplifications, the modular vops went
;;; haywire because they inherit from vops of particular names.
(macrolet ((def (fun-name name name/c scs primtype type cost
                          &optional (val-xform 'identity) &rest extra
                          &aux (note (format nil "inline ~(~a~) arithmetic" type))
                               (op (ecase fun-name (+ 'add) (- 'sub) (* 'mul)))
                               (emit (if (eq op 'mul) 'emit-inline-smul 'emit-inline-add-sub)))
             `(progn
                (define-vop (,name fast-safe-arith-op)
                  (:translate ,fun-name)
                  (:args (x :scs (,@scs) ,@(if (eq op 'sub)
                                               '(:target r)))
                         (y :scs (,@scs immediate)))
                  (:arg-types ,primtype ,primtype)
                  (:results (r :scs ,scs :load-if nil))
                  (:result-types ,primtype)
                  (:temporary (:sc unsigned-reg) temp)
                  (:vop-var vop)
                  (:note ,note)
                  (:generator ,(1+ cost)
                   (,emit ',op x y r temp vop ',val-xform ,@extra)))
                (define-vop (,name/c fast-safe-arith-op)
                  (:translate ,fun-name)
                  (:args (x :scs ,scs))
                  (:info y)
                  (:arg-types ,primtype (:constant ,type))
                  (:results (r :scs ,scs :load-if nil))
                  (:result-types ,primtype)
                  (:temporary (:sc unsigned-reg) temp)
                  (:vop-var vop)
                  (:note ,note)
                  (:generator ,cost
                   (,emit ',op x (,val-xform y) r temp vop ',val-xform ,@extra))))))
  (def + fast-+/fixnum=>fixnum fast-+-c/fixnum=>fixnum
       (any-reg control-stack) tagged-num fixnum 1 fixnumize)
  (def + fast-+/signed=>signed fast-+-c/signed=>signed
       (signed-reg signed-stack) signed-num (signed-byte 64) 3)
  (def + fast-+/unsigned=>unsigned fast-+-c/unsigned=>unsigned
       (unsigned-reg unsigned-stack) unsigned-num (unsigned-byte 64) 3)

  (def + fast-+/signed-unsigned fast-+-c/signed-unsigned
      (signed-reg signed-stack unsigned-reg unsigned-stack) (:or signed-num unsigned-num) (signed-byte 64) 5)

  (def - fast--/fixnum=>fixnum fast---c/fixnum=>fixnum
       (any-reg control-stack) tagged-num fixnum 1 fixnumize)
  (def - fast--/signed=>signed fast---c/signed=>signed
       (signed-reg signed-stack) signed-num (signed-byte 64) 3)
  (def - fast--/unsigned=>unsigned fast---c/unsigned=>unsigned
       (unsigned-reg unsigned-stack) unsigned-num (unsigned-byte 64) 3)

  (def - fast--/signed-unsigned fast---c/signed-unsigned
      (signed-reg signed-stack unsigned-reg unsigned-stack) (:or signed-num unsigned-num) (signed-byte 64) 5)

  (def * fast-*/fixnum=>fixnum fast-*-c/fixnum=>fixnum
       (any-reg control-stack) tagged-num fixnum 1 identity t)
  (def * fast-*/signed=>signed fast-*-c/signed=>signed
       (signed-reg signed-stack) signed-num (signed-byte 64) 3 identity nil)
  ;; unsigned is different because MUL always uses RAX:RDX as 1st operand.
  )

(define-vop (fast--/unsigned=>signed fast-safe-arith-op)
  (:translate -)
  (:args (x :scs (unsigned-reg unsigned-stack) :target r)
         (y :scs (unsigned-reg unsigned-stack immediate) :load-if nil))
  (:arg-types unsigned-num unsigned-num)
  (:results (r :scs (signed-reg signed-stack) :load-if nil))
  (:result-types signed-num)
  (:temporary (:sc unsigned-reg) temp)
  (:vop-var vop)
  (:note "inline (unsigned-byte 64) arithmetic")
  (:generator 4
    (emit-inline-add-sub 'sub x y r temp vop 'identity)))

;;;; Special logand cases: (logand signed unsigned) => unsigned

(define-vop (fast-logand/signed-unsigned=>unsigned
             fast-logand/unsigned=>unsigned)
  (:args (x :target r :scs (signed-reg)
            :load-if (not (and (sc-is x signed-stack)
                               (sc-is y unsigned-reg)
                               (sc-is r unsigned-stack)
                               (location= x r))))
         (y :scs (unsigned-reg unsigned-stack)))
  (:arg-types signed-num unsigned-num))

;; This special case benefits from the special case for c/unsigned=>unsigned.
;; In particular, converting a (signed-byte 64) to (unsigned-byte 64) by
;; way of (LDB (byte 64 0)) doesn't need an AND instruction.
(define-vop (fast-logand-c/signed-unsigned=>unsigned
             fast-logand-c/unsigned=>unsigned)
  (:args (x :target r :scs (signed-reg)))
  (:arg-types signed-num (:constant (unsigned-byte 64))))

(define-vop (fast-logand/unsigned-signed=>unsigned
             fast-logand/unsigned=>unsigned)
  (:args (x :target r :scs (unsigned-reg)
            :load-if (not (and (sc-is x unsigned-stack)
                               (sc-is y signed-reg)
                               (sc-is r unsigned-stack)
                               (location= x r))))
         (y :scs (signed-reg signed-stack)))
  (:arg-types unsigned-num signed-num))

;;;; multiplication and division

(define-vop (fast-*/unsigned=>unsigned fast-safe-arith-op)
  (:translate *)
  (:args (x :scs (unsigned-reg) :target eax)
         (y :scs (unsigned-reg unsigned-stack)))
  (:arg-types unsigned-num unsigned-num)
  (:temporary (:sc unsigned-reg :offset rax-offset :target r
                   :from (:argument 0) :to :result) eax)
  (:temporary (:sc unsigned-reg :offset rdx-offset
                   :from :eval :to :result) edx)
  (:ignore edx)
  (:results (r :scs (unsigned-reg)))
  (:result-types unsigned-num)
  (:note "inline (unsigned-byte 64) arithmetic")
  (:vop-var vop)
  (:generator 4
    (move eax x)
    (inst mul y)
    (move r eax)))

(define-vop (fast-*-c/unsigned=>unsigned fast-safe-arith-op)
  (:translate *)
  (:args (x :scs (unsigned-reg) :target eax))
  (:info y)
  (:arg-types unsigned-num (:constant (unsigned-byte 64)))
  (:temporary (:sc unsigned-reg :offset rax-offset :target r
                   :from (:argument 0) :to :result) eax)
  (:temporary (:sc unsigned-reg :offset rdx-offset
                   :from :eval :to :result) edx)
  (:ignore edx)
  (:results (r :scs (unsigned-reg)))
  (:result-types unsigned-num)
  (:note "inline (unsigned-byte 64) arithmetic")
  (:vop-var vop)
  (:generator 3
    (move eax x)
    (inst mul :qword (ref-shared-qword-literal y))
    (move r eax)))

(defun wordpair-to-bignum (result flag low high node)
  (inst push high)
  (inst push low)
  (inst mov :byte result flag)
  (call-reg-specific-asm-routine node "BIGNUM-TO-" result))
(defun unsigned-wordpair-to-bignum (result flag low high node)
  (inst push high)
  (inst push low)
  (inst mov :byte result flag)
  (call-reg-specific-asm-routine node "+BIGNUM-TO-" result))

(define-vop (*/signed=>integer)
  (:translate *)
  (:args (x :scs (signed-reg) :target rax)
         (y :scs (signed-reg)))
  (:arg-types signed-num signed-num)
  (:temporary (:sc signed-reg :offset rax-offset :from (:argument 0))
              rax)
  (:temporary (:sc signed-reg :offset rdx-offset :from (:argument 1))
              rdx)
  (:temporary (:sc signed-reg :from :eval) twodigit)
  (:temporary (:sc complex-double-reg :offset 0) scratch)
  (:ignore scratch)
  (:results (r :scs (descriptor-reg)))
  (:policy :fast-safe)
  (:vop-var vop)
  (:node-var node)
  (:generator 10
    (move rax x)
    (inst imul y)
    (inst mov :byte twodigit 1) ; = "yes"
    (inst jmp :o allocate)
    (move r rax)
    (inst shl r 1)
    (inst jmp :no DONE)
    (zeroize twodigit) ; = "no"
    allocate
    (wordpair-to-bignum r twodigit rax rdx node)
    DONE))

(define-vop (+/signed=>integer)
  (:translate +)
  (:args (x :scs (signed-reg) :target low)
         (y :scs (signed-reg)))
  (:arg-types signed-num signed-num)
  (:temporary (:sc signed-reg :from (:argument 0)) low)
  (:temporary (:sc signed-reg :from :eval) high twodigit)
  (:temporary (:sc complex-double-reg :offset 0) scratch)
  (:ignore scratch)
  (:results (r :scs (descriptor-reg)))
  (:policy :fast-safe)
  (:vop-var vop)
  (:node-var node)
  (:generator 7
    (move low x)
    (inst add low y)
    (inst mov :byte twodigit 1)
    (inst jmp :o allocate)
    (move r low)
    (inst shl r 1)
    (inst jmp :no DONE)
    (zeroize twodigit)
    allocate
    ;; high := CF broadcast into all bits. Ignored if single-digit
    (inst sbb high high)
    (wordpair-to-bignum r twodigit low high node)
    DONE))

(define-vop (-/signed=>integer)
  (:translate -)
  (:args (x :scs (signed-reg) :target low)
         (y :scs (signed-reg)))
  (:arg-types signed-num signed-num)
  (:temporary (:sc signed-reg :from (:argument 0)) low)
  (:temporary (:sc signed-reg :from :eval) high twodigit)
  (:temporary (:sc complex-double-reg :offset 0) scratch)
  (:ignore scratch)
  (:results (r :scs (descriptor-reg)))
  (:policy :fast-safe)
  (:vop-var vop)
  (:node-var node)
  (:generator 7
    (move low x)
    (inst sub low y)
    (inst mov :byte twodigit 1)
    (inst jmp :o allocate)
    (move r low)
    (inst shl r 1)
    (inst jmp :no DONE)
    (zeroize twodigit)
    allocate
    (inst cmc)
    (inst sbb high high)
    (wordpair-to-bignum r twodigit low high node)
    DONE))

(define-vop (*/unsigned=>integer)
  (:translate *)
  (:args (x :scs (unsigned-reg) :target rax)
         (y :scs (unsigned-reg)))
  (:arg-types unsigned-num unsigned-num)
  (:temporary (:sc unsigned-reg :offset rax-offset :from (:argument 0)) rax)
  (:temporary (:sc unsigned-reg :offset rdx-offset :from (:argument 1)) rdx)
  (:temporary (:sc signed-reg :from (:argument 2)) multidigit)
  (:temporary (:sc complex-double-reg :offset 0) scratch)
  (:ignore scratch)
  (:results (r :scs (descriptor-reg)))
  (:policy :fast-safe)
  (:vop-var vop)
  (:node-var node)
  (:generator 10
    (move rax x)
    (inst mul y)
    (inst mov :byte multidigit 1) ; might need 2 or 3 digits to represent
    ;; OF implies RDX nonzero. Sign bit of RDX gets tested in asm routine
    (inst jmp :o allocate)
    (move r rax)
    (inst shl r 1) ; n-fixnum-tag-bits
    ;; If we shifted out a 1 bit from the low digit, then it's a 2-digit bignum
    (inst jmp :c allocate)
    ;; If not-CF and not-OF then the top 2 bits of the low digit are both zero
    ;; and the result is a fixnum, otherwise a 1-digit bignumm
    (inst jmp :no DONE)
    (zeroize multidigit)
    allocate
    (unsigned-wordpair-to-bignum r multidigit rax rdx node)
    DONE))

(define-vop (ash-left-add-signed)
  (:translate ash-left-add)
  (:args (x :scs (signed-reg))
         (shift :scs (unsigned-reg immediate) :target rcx)
         (add :scs (unsigned-reg)))
  (:arg-types signed-num unsigned-num unsigned-num)
  (:temporary (:sc signed-reg :offset rax-offset) rax)
  (:temporary (:sc signed-reg :offset rdx-offset) rdx)
  (:temporary (:sc signed-reg :offset rcx-offset :from (:argument 1)
               :unused-if (sc-is shift immediate)) rcx)
  (:temporary (:sc signed-reg :from :eval) twodigit)
  (:temporary (:sc complex-double-reg :offset 0) scratch)
  (:ignore scratch)
  (:results (r :scs (descriptor-reg)))
  (:policy :fast-safe)
  (:vop-var vop)
  (:node-var node)
  (:generator 10
    (let ((shift (if (sc-is shift immediate)
                     (tn-value shift)
                     shift)))
      (cond ((and (fixnump shift)
                  (< shift 63))
             (inst mov rax (ash 1 shift))
             (inst imul x)
             (inst lea rax (ea add rax))
             (inst mov :byte twodigit 1)
             (inst jmp :o allocate))
            (t
             (unless (fixnump shift)
               (move rcx shift)
               (setf shift :cl))
             (move rax x)
             (inst cqo)
             (inst shld rdx rax shift)
             (inst shl rax shift)
             (inst add rax add)
             (inst mov twodigit rax)
             (inst sar twodigit 63)
             (inst cmp rdx twodigit)
             (inst mov :byte twodigit 1)
             (inst jmp :ne allocate))))
    (move r rax)
    (inst shl r 1)
    (inst jmp :no DONE)
    (zeroize twodigit)
    allocate
    (wordpair-to-bignum r twodigit rax rdx node)
    DONE))

(define-vop ()
  (:translate ash-left-word-add)
  (:args (x :scs (signed-reg))
         (add :scs (unsigned-reg)))
  (:arg-types signed-num unsigned-num)
  (:temporary (:sc signed-reg) twodigit)
  (:temporary (:sc complex-double-reg :offset 0) scratch)
  (:ignore scratch)
  (:results (r :scs (descriptor-reg)))
  (:policy :fast-safe)
  (:vop-var vop)
  (:node-var node)
  (:generator 10
    (inst mov twodigit add)
    (inst sar twodigit 63)
    (inst cmp twodigit x)
    (inst mov :byte twodigit 1)
    (inst jmp :ne allocate)
    (move r add)
    (inst shl r 1)
    (inst jmp :no DONE)
    (zeroize twodigit)
    allocate
    (wordpair-to-bignum r twodigit add x node)
    DONE))

(define-vop (ash-left-add-unsigned)
  (:translate ash-left-add)
  (:args (x :scs (unsigned-reg))
         (shift :scs (unsigned-reg immediate) :target rcx)
         (add :scs (unsigned-reg)))
  (:arg-types unsigned-num unsigned-num unsigned-num)
  (:temporary (:sc unsigned-reg :offset rax-offset) rax)
  (:temporary (:sc unsigned-reg :offset rdx-offset) rdx)
  (:temporary (:sc signed-reg :offset rcx-offset :from (:argument 1)
               :unused-if (sc-is shift immediate)) rcx)
  (:temporary (:sc signed-reg :from (:argument 2)) multidigit)
  (:temporary (:sc complex-double-reg :offset 0) scratch)
  (:ignore scratch)
  (:results (r :scs (descriptor-reg)))
  (:policy :fast-safe)
  (:vop-var vop)
  (:node-var node)
  (:generator 10
    (sc-case shift
      (immediate
       (inst mov rax (ash 1 (tn-value shift))))
      (t
       (move rcx shift :dword)
       (inst mov rax 1)
       (inst shl rax :cl)))
    (inst mul x)
    (inst lea rax (ea add rax))
    (inst mov :byte multidigit 1) ; might need 2 or 3 digits to represent
    ;; OF implies RDX nonzero. Sign bit of RDX gets tested in asm routine
    (inst jmp :o allocate)
    (move r rax)
    (inst shl r 1)                      ; n-fixnum-tag-bits
    ;; If we shifted out a 1 bit from the low digit, then it's a 2-digit bignum
    (inst jmp :c allocate)
    ;; If not-CF and not-OF then the top 2 bits of the low digit are both zero
    ;; and the result is a fixnum, otherwise a 1-digit bignumm
    (inst jmp :no DONE)
    (zeroize multidigit)
    allocate
    (unsigned-wordpair-to-bignum r multidigit rax rdx node)
    DONE))

(defun signed=>bignum-in-reg (node reg) ; arg/result in same reg
  (call-reg-specific-asm-routine node "ALLOC-SIGNED-BIGNUM-IN-" reg))

(defun unsigned=>bignum-in-reg (node reg)
  ;; one or two-word output from 1 word input. Same reg for arg/result
  (call-reg-specific-asm-routine node "ALLOC-UNSIGNED-BIGNUM-IN-" reg))

(defun two-word-bignum (node reg)
  (call-reg-specific-asm-routine node "TWO-WORD-BIGNUM-TO-" reg))

(define-vop (+/unsigned=>integer)
  (:translate +)
  (:args (x :scs (unsigned-reg))
         (y :scs (unsigned-reg)))
  (:arg-types unsigned-num unsigned-num)
  (:results (r :scs (descriptor-reg)))
  (:policy :fast-safe)
  (:vop-var vop)
  (:node-var node)
  (:generator 8
    (cond ((location= r x))
          ((location= r y)
           (setf y x))
          (t
           (move r x)))
    (inst add r y)
    (inst jmp :c TWO)
    (inst jmp :s TWO)
    (inst shl r 1)
    (inst jmp :no DONE)
    ;; This is a little like MOVE-FROM-SIGNED or MOVE-FROM-UNSIGNED
    ;; but not quite the same as either.
    ;; Restore the bits of R, but we don't need the carry - it has to be 0
    ;; because if it weren't 0 then OF would have been set.
    (inst shr r 1)
    ;; "signed" meaning that bit index 63 which happens to be 0 is
    ;; in fact a sign bit and not the 64th bit of the significand.
    (signed=>bignum-in-reg node r)
    (inst jmp DONE)
    TWO
    (two-word-bignum node r)
    DONE))

(define-vop (-/unsigned=>integer)
  (:translate -)
  (:args (x :scs (unsigned-reg) :target low)
         (y :scs (unsigned-reg)))
  (:arg-types unsigned-num unsigned-num)
  (:temporary (:sc unsigned-reg :from (:argument 0)) low)
  (:temporary (:sc unsigned-reg :from :eval) high twodigit)
  (:temporary (:sc complex-double-reg :offset 0) scratch)
  (:ignore scratch)
  (:results (r :scs (descriptor-reg)))
  (:policy :fast-safe)
  (:vop-var vop)
  (:node-var node)
  (:generator 8
    (move low x)
    (inst sub low y)
    (inst mov :byte twodigit 1)

    (inst jmp :c negative)
    (inst jmp :s allocate)
    (inst jmp positive)
    negative
    (inst jmp :ns allocate)
    positive

    (move r low)
    (inst shl r 1)
    (inst jmp :no DONE)
    (zeroize twodigit)
    allocate
    (inst sbb high high)
    (wordpair-to-bignum r twodigit low high node)
    DONE))

(define-vop (%negate/unsigned=>integer)
  (:translate %negate)
  (:args (x :scs (unsigned-reg) :target low))
  (:arg-types unsigned-num)
  (:temporary (:sc unsigned-reg :from (:argument 0)) low)
  (:temporary (:sc unsigned-reg :from :eval) high twodigit)
  (:temporary (:sc complex-double-reg :offset 0) scratch)
  (:ignore scratch)
  (:results (r :scs (descriptor-reg)))
  (:policy :fast-safe)
  (:vop-var vop)
  (:node-var node)
  (:generator 8
    (move low x)
    (inst neg low)
    (inst mov :byte twodigit 1)

    (inst jmp :c negative)
    (inst jmp :s allocate)
    (inst jmp positive)
    negative
    (inst jmp :ns allocate)
    positive

    (move r low)
    (inst shl r 1)
    (inst jmp :no DONE)
    (zeroize twodigit)
    allocate
    (inst sbb high high)
    (wordpair-to-bignum r twodigit low high node)
    DONE))

(define-vop (%negate/signed=>integer)
  (:translate %negate)
  (:args (x :scs (signed-reg) :target low))
  (:arg-types signed-num)
  (:temporary (:sc signed-reg :from (:argument 0)) low)
  (:temporary (:sc signed-reg :from :eval) high twodigit)
  (:temporary (:sc complex-double-reg :offset 0) scratch)
  (:ignore scratch)
  (:results (r :scs (descriptor-reg)))
  (:policy :fast-safe)
  (:vop-var vop)
  (:node-var node)
  (:generator 7
    (move low x)
    (inst neg low)
    (inst mov :byte twodigit 1)
    (inst jmp :o allocate)
    (move r low)
    (inst shl r 1)
    (inst jmp :no DONE)
    (zeroize twodigit)
    allocate
    (inst cmc)
    (inst sbb high high)
    (wordpair-to-bignum r twodigit low high node)
    DONE))

(define-vop (overflow*-fixnum)
  (:translate overflow*)
  (:args (x :scs (any-reg))
         (y :scs (signed-reg)))
  (:arg-types tagged-num tagged-num)
  (:info type)
  (:results (r :scs (any-reg) :from :load))
  (:result-types tagged-num)
  (:policy :fast-safe)
  (:vop-var vop)
  (:generator 1
    (let* ((*location-context* (unless (eq type 'fixnum)
                                 type))
           (error (generate-error-code vop 'sb-kernel::mul-overflow2-error x y)))
      (move r x)
      (inst imul r y)
      (inst jmp :o error))))

(define-vop (overflow*-fixnum*/c)
  (:translate overflow*)
  (:args (x :scs (any-reg)))
  (:arg-types tagged-num (:constant (signed-byte 32)))
  (:info y type)
  (:results (r :scs (any-reg) :from :load))
  (:result-types tagged-num)
  (:policy :fast-safe)
  (:vop-var vop)
  (:generator 2
    (let* ((*location-context* (unless (eq type 'fixnum)
                                 type))
           (error (generate-error-code+ (lambda ()
                                          (inst mov r (fixnumize y)))
                                        vop
                                        'sb-kernel::mul-overflow2-error x r)))
      (inst imul r x y)
      (inst jmp :o error))))

(define-vop (overflow*-signed)
  (:translate overflow*)
  (:args (x :scs (signed-reg))
         (y :scs (signed-reg)))
  (:arg-types signed-num signed-num)
  (:info type)
  (:results (r :scs (signed-reg) :from :load))
  (:result-types signed-num)
  (:policy :fast-safe)
  (:vop-var vop)
  (:generator 3
    (let* ((*location-context* (unless (eq type 'fixnum)
                                 type))
           (error (generate-error-code vop 'sb-kernel::mul-overflow2-error x y)))
      (move r x)
      (inst imul r y)
      (inst jmp :o error))))

(define-vop (overflow*-signed=>unsigned)
  (:translate overflow*)
  (:args (x :scs (signed-reg) :to :save)
         (y :scs (signed-reg) :to :save))
  (:arg-types signed-num signed-num)
  (:info type)
  (:temporary (:sc signed-reg :offset rax-offset :target r :to :result) rax)
  (:temporary (:sc signed-reg :offset rdx-offset) rdx)
  (:results (r :scs (unsigned-reg)))
  (:result-types unsigned-num)
  (:policy :fast-safe)
  (:vop-var vop)
  (:generator 5
    (let* ((*location-context* (unless (eq type 'fixnum)
                                 type))
           (error (generate-error-code vop 'sb-kernel::mul-overflow2-error x y)))
      (move rax x)
      (inst imul y)
      (inst test rdx rdx)
      (inst jmp :nz error)
      (move r rax))))

(define-vop (overflow*-unsigned)
  (:translate overflow*)
  (:args (x :scs (unsigned-reg) :to :save)
         (y :scs (unsigned-reg) :to :save))
  (:arg-types unsigned-num unsigned-num)
  (:info type)
  (:temporary (:sc signed-reg :offset rax-offset :target r :to :result) rax)
  (:temporary (:sc signed-reg :offset rdx-offset) rdx)
  (:results (r :scs (unsigned-reg)))
  (:ignore rdx)
  (:result-types unsigned-num)
  (:policy :fast-safe)
  (:vop-var vop)
  (:generator 4
    (let* ((*location-context* (unless (eq type 'fixnum)
                                 type))
           (error (generate-error-code vop 'sb-kernel::mul-overflow2-error x y)))
      (move rax x)
      (inst mul y)
      (inst jmp :o error)
      (move r rax))))

(define-vop (overflow*-signed-unsigned=>unsigned)
  (:translate overflow*)
  (:args (x :scs (signed-reg) :to :save)
         (y :scs (unsigned-reg) :to :save))
  (:arg-types signed-num unsigned-num)
  (:info type)
  (:temporary (:sc signed-reg :offset rax-offset :target r :to :result) rax)
  (:temporary (:sc signed-reg :offset rdx-offset) rdx)
  (:results (r :scs (unsigned-reg)))
  (:result-types unsigned-num)
  (:policy :fast-safe)
  (:vop-var vop)
  (:generator 5
    (let* ((*location-context* (unless (eq type 'fixnum)
                                 type))
           (error (generate-error-code vop 'sb-kernel::mul-overflow2-error x y)))
      (assemble ()
        (move rax x)
        (inst test y y)
        (inst jmp :z SKIP)
        (inst test rax rax)
        (inst jmp :s error)
        SKIP
        (inst mul y)
        (inst test rdx rdx)
        (inst jmp :nz error)
        (move r rax)))))

(define-vop (overflow*-signed-unsigned=>signed)
  (:translate overflow*)
  (:args (x :scs (signed-reg))
         (y :scs (unsigned-reg)))
  (:arg-types signed-num unsigned-num)
  (:info type)
  (:temporary (:sc unsigned-reg) temp)
  (:results (r :scs (signed-reg) :from :load))
  (:result-types signed-num)
  (:policy :fast-safe)
  (:vop-var vop)
  (:generator 6
    (let* ((*location-context* (unless (eq type 'fixnum)
                                 type))
           (error (generate-error-code vop 'sb-kernel::mul-overflow2-error x y)))
      (assemble ()
        (move r x)
        (inst imul r y)
        (inst set :o temp)
        (inst test y y)
        (inst jmp :ns SKIP)
        (inst test x x)
        (inst jmp :z DONE)
        (inst cmp x -1)
        (inst jmp :ne error)
        (inst cmp r y)
        (inst jmp :e DONE)
        (inst jmp error)
        SKIP
        (inst test :byte temp temp)
        (inst jmp :nz error)
        DONE))))

(define-vop (overflow+-unsigned)
  (:translate overflow+)
  (:args (x :scs (unsigned-reg))
         (y :scs (unsigned-reg (immediate
                                (plausible-signed-imm32-operand-p (tn-value tn))))))
  (:arg-types unsigned-num unsigned-num)
  (:info type)
  (:results (r :scs (unsigned-reg) :from (:argument 0)))
  (:result-types unsigned-num)
  (:policy :fast-safe)
  (:vop-var vop)
  (:generator 2
    (move r x)
    (inst add r (if (sc-is y immediate)
                    (tn-value y)
                    y))
    (let* ((*location-context* (unless (eq type 'fixnum)
                                 type))
           (error (generate-error-code vop 'sb-kernel::add-sub-overflow-error r)))
      (inst jmp :c error))))

(define-vop (overflow+-signed)
  (:translate overflow+)
  (:args (x :scs (signed-reg))
         (y :scs (signed-reg (immediate
                              (plausible-signed-imm32-operand-p (tn-value tn))))))
  (:arg-types signed-num signed-num)
  (:info type)
  (:results (r :scs (signed-reg) :from (:argument 0)))
  (:result-types signed-num)
  (:policy :fast-safe)
  (:vop-var vop)
  (:generator 2
    (move r x)
    (inst add r (if (sc-is y immediate)
                    (tn-value y)
                    y))
    (let* ((*location-context* (unless (eq type 'fixnum)
                                 type))
           (error (generate-error-code vop 'sb-kernel::add-sub-overflow-error r)))
      (inst jmp :o error))))

(define-vop (overflow+-fixnum)
  (:translate overflow+)
  (:args (x :scs (any-reg))
         (y :scs (any-reg (immediate
                           (plausible-signed-imm32-operand-p (fixnumize (tn-value tn)))))))
  (:arg-types tagged-num tagged-num)
  (:info type)
  (:results (r :scs (any-reg) :from (:argument 0)))
  (:result-types tagged-num)
  (:policy :fast-safe)
  (:vop-var vop)
  (:generator 1
    (move r x)
    (inst add r (if (sc-is y immediate)
                    (fixnumize (tn-value y))
                    y))
    (let* ((*location-context* (unless (eq type 'fixnum)
                                 type))
           (error (generate-error-code vop 'sb-kernel::add-sub-overflow-error r)))
      (inst jmp :o error))))

(define-vop (overflow+-signed=>unsigned)
  (:translate overflow+)
  (:args (x :scs (signed-reg))
         (y :scs (signed-reg)))
  (:arg-types signed-num signed-num)
  (:info type)
  (:temporary (:sc unsigned-reg) temp1 temp2)
  (:results (r :scs (unsigned-reg) :from :load))
  (:result-types unsigned-num)
  (:policy :fast-safe)
  (:vop-var vop)
  (:generator 5
    (let* ((*location-context* (unless (eq type 'fixnum)
                                 type))
           (error (generate-error-code vop 'sb-kernel::add-overflow2-error x y)))
      (move temp1 x)
      (inst sar temp1 63)
      (move temp2 y)
      (inst sar temp2 63)
      (move r x)
      (inst add r y)
      (inst adc :dword temp1 temp2)
      (inst test :byte temp1 1)
      (inst jmp :ne error))))

(define-vop (overflow+-unsigned+signed=>signed)
  (:translate overflow+)
  (:args (x :scs (unsigned-reg) :to :save)
         (y :scs (signed-reg)))
  (:arg-types unsigned-num signed-num)
  (:info type)
  (:temporary (:sc unsigned-reg) tmp)
  (:results (r :scs (signed-reg)))
  (:result-types signed-num)
  (:policy :fast-safe)
  (:vop-var vop)
  (:generator 3
    (let* ((*location-context* (unless (eq type 'fixnum)
                                 type))
           (error (generate-error-code vop 'sb-kernel::signed-unsigned-add-overflow-error r)))
      (inst lea r (ea x y))
      (inst mov tmp -9223372036854775808)
      (inst add tmp r)
      (inst cmp tmp x)
      (inst jmp :b error))))

(define-vop (overflow+-unsigned+signed=>unsigned)
  (:translate overflow+)
  (:args (in-x :scs (unsigned-reg) :target x)
         (in-y :scs (signed-reg) :target y))
  (:arg-types unsigned-num signed-num)
  (:info type)
  (:temporary (:sc unsigned-reg ;; :from (:argument 2) FIXME
                   ) x y)
  (:results (r :scs (unsigned-reg) :from :load))
  (:result-types unsigned-num)
  (:policy :fast-safe)
  (:vop-var vop)
  (:generator 3
    (let* ((*location-context* (unless (eq type 'fixnum)
                                 type))
           (error (generate-error-code vop 'sb-kernel::signed-unsigned-add-overflow-error r)))
      (inst mov r -9223372036854775808)
      (move y in-y)
      (if (location= x in-x)
          (inst add x r)
          (inst lea x (ea in-x r)))
      (inst add y x)
      (inst lea r (ea r y))
      (inst jmp :o error))))

(define-vop (overflow-unsigned)
  (:translate overflow-)
  (:args (x :scs (unsigned-reg))
         (y :scs (unsigned-reg)))
  (:arg-types unsigned-num unsigned-num)
  (:info type)
  (:results (r :scs (unsigned-reg) :from (:argument 0)))
  (:result-types unsigned-num)
  (:policy :fast-safe)
  (:vop-var vop)
  (:generator 2
    (move r x)
    (inst sub r y)
    (let* ((*location-context* (unless (eq type 'fixnum)
                                 type))
           (error (generate-error-code vop 'sb-kernel::sub-overflow-error r)))
      (inst jmp :c error))))

(define-vop (overflow-signed)
  (:translate overflow-)
  (:args (x :scs (signed-reg))
         (y :scs (signed-reg)))
  (:arg-types signed-num signed-num)
  (:info type)
  (:results (r :scs (signed-reg) :from (:argument 0)))
  (:result-types signed-num)
  (:policy :fast-safe)
  (:vop-var vop)
  (:generator 2
    (move r x)
    (inst sub r y)
    (let* ((*location-context* (unless (eq type 'fixnum)
                                 type))
           (error (generate-error-code vop 'sb-kernel::sub-overflow-error r)))
      (inst jmp :o error))))

(define-vop (overflow-fixnum)
  (:translate overflow-)
  (:args (x :scs (any-reg))
         (y :scs (any-reg (immediate
                           (plausible-signed-imm32-operand-p (fixnumize (tn-value tn)))))))
  (:arg-types tagged-num tagged-num)
  (:info type)
  (:results (r :scs (any-reg) :from (:argument 0)))
  (:result-types tagged-num)
  (:policy :fast-safe)
  (:vop-var vop)
  (:generator 1
    (move r x)
    (inst sub r (if (sc-is y immediate)
                    (fixnumize (tn-value y))
                    y))
    (let* ((*location-context* (unless (eq type 'fixnum)
                                 type))
           (error (generate-error-code vop 'sb-kernel::sub-overflow-error r)))
      (inst jmp :o error))))

(define-vop (overflow-unsigned=>signed)
  (:translate overflow-)
  (:args (x :scs (unsigned-reg))
         (y :scs (unsigned-reg)))
  (:arg-types unsigned-num unsigned-num)
  (:info type)
  (:temporary (:sc unsigned-reg) temp1 temp2)
  (:results (r :scs (signed-reg) :from :load))
  (:result-types signed-num)
  (:policy :fast-safe)
  (:vop-var vop)
  (:generator 5
    (let* ((*location-context* (unless (eq type 'fixnum)
                                 type))
           (error (generate-error-code vop 'sb-kernel::sub-overflow2-error x y)))
      (zeroize temp1)
      (move r x)
      (inst sub r y)
      (inst sbb :dword temp1 temp1)
      (inst and :dword temp1 1)
      (inst mov temp2 r)
      (inst shr temp2 63)
      (inst xor temp2 temp1)
      (inst jmp :ne error))))

(define-vop (overflow-signed=>unsigned)
  (:translate overflow-)
  (:args (x :scs (signed-reg))
         (y :scs (signed-reg)))
  (:arg-types signed-num signed-num)
  (:info type)
  (:temporary (:sc unsigned-reg) temp1 temp2)
  (:results (r :scs (unsigned-reg) :from :load))
  (:result-types unsigned-num)
  (:policy :fast-safe)
  (:vop-var vop)
  (:generator 5
    (let* ((*location-context* (unless (eq type 'fixnum)
                                 type))
           (error (generate-error-code vop 'sb-kernel::sub-overflow2-error x y)))
      (move temp1 x)
      (inst sar temp1 63)
      (move temp2 y)
      (inst sar temp2 63)
      (move r x)
      (inst sub r y)
      (inst sbb :dword temp1 temp2)
      (inst test :byte temp1 1)
      (inst jmp :ne error))))

(define-vop (overflow-unsigned-signed=>signed)
  (:translate overflow-)
  (:args (x :scs (unsigned-reg) :to :save)
         (y :scs (signed-reg) :to :save))
  (:arg-types unsigned-num signed-num)
  (:info type)
  (:temporary (:sc unsigned-reg) tmp)
  (:results (r :scs (signed-reg)))
  (:result-types signed-num)
  (:policy :fast-safe)
  (:vop-var vop)
  (:generator 3
    (let* ((*location-context* (unless (eq type 'fixnum)
                                 type))
           (error (generate-error-code vop 'sb-kernel::signed-unsigned-add-overflow-error r)))
      (inst mov tmp -9223372036854775808)
      (inst lea tmp (ea y tmp))
      (inst mov r x)
      (inst sub r y)
      (inst cmp x tmp)
      (inst jmp :nb error))))

(define-vop (overflow-signed-unsigned=>signed)
  (:translate overflow-)
  (:args (x :scs (signed-reg) :to :save)
         (y :scs (unsigned-reg) :to :save))
  (:arg-types signed-num unsigned-num)
  (:info type)
  (:temporary (:sc unsigned-reg) tmp)
  (:results (r :scs (signed-reg)))
  (:result-types signed-num)
  (:policy :fast-safe)
  (:vop-var vop)
  (:generator 3
    (let* ((*location-context* (unless (eq type 'fixnum)
                                 type))
           (error (generate-error-code vop 'sb-kernel::sub-overflow2-error x y)))
      (inst mov tmp -9223372036854775808)
      (inst lea tmp (ea x tmp))
      (inst cmp tmp y)
      (inst jmp :b error)
      (move r x)
      (inst sub r y))))

(define-vop (overflow-signed-unsigned=>unsigned)
  (:translate overflow-)
  (:args (x :scs (signed-reg) :to :save)
         (y :scs (unsigned-reg) :to :save))
  (:arg-types signed-num unsigned-num)
  (:info type)
  (:results (r :scs (unsigned-reg)))
  (:result-types unsigned-num)
  (:policy :fast-safe)
  (:vop-var vop)
  (:generator 3
    (let* ((*location-context* (unless (eq type 'fixnum)
                                 type))
           (error (generate-error-code vop 'sb-kernel::sub-overflow2-error x y)))
      (move r x)
      (inst sub r y)
      (inst jmp :b error)
      (inst test x x)
      (inst jmp :s error))))

(define-vop (overflow-unsigned-signed=>unsigned)
  (:translate overflow-)
  (:args (x :scs (unsigned-reg) :to :save)
         (y :scs (signed-reg) :to :save))
  (:arg-types unsigned-num signed-num)
  (:info type)
  (:temporary (:sc unsigned-reg) tmp)
  (:results (r :scs (unsigned-reg)))
  (:result-types unsigned-num)
  (:policy :fast-safe)
  (:vop-var vop)
  (:generator 3
    (let* ((*location-context* (unless (eq type 'fixnum)
                                 type))
           (error (generate-error-code vop 'sb-kernel::sub-overflow2-error x y)))
      (inst mov tmp -9223372036854775808)
      (inst lea r (ea x tmp))
      (inst sub r y)
      (inst jmp :o error)
      (inst add r tmp))))

(define-vop (overflow-negate-signed)
  (:translate overflow-negate)
  (:args (x :scs (signed-reg)))
  (:arg-types signed-num)
  (:info type)
  (:results (r :scs (signed-reg)))
  (:result-types signed-num)
  (:policy :fast-safe)
  (:vop-var vop)
  (:generator 2
    (let* ((*location-context* (unless (eq type 'fixnum)
                                 type))
           (error (generate-error-code vop 'sb-kernel::sub-overflow-error r)))
      (move r x)
      (inst neg r)
      (inst jmp :o error))))

(define-vop (overflow-negate-unsigned)
  (:translate overflow-negate)
  (:args (x :scs (unsigned-reg)))
  (:arg-types unsigned-num)
  (:info type)
  (:results (r :scs (unsigned-reg)))
  (:result-types unsigned-num)
  (:policy :fast-safe)
  (:vop-var vop)
  (:generator 2
    (let* ((*location-context* (unless (eq type 'fixnum)
                                 type))
           (error (generate-error-code vop 'sb-kernel::negate-overflow-error x)))
      (inst test x x)
      (inst jmp :nz error)
      (unless (location= r x)
        (zeroize r)))))

(define-vop (overflow-negate-unsigned=>signed)
  (:translate overflow-negate)
  (:args (x :scs (unsigned-reg)))
  (:arg-types unsigned-num)
  (:temporary (:sc unsigned-reg) temp)
  (:info type)
  (:results (r :scs (signed-reg)))
  (:result-types signed-num)
  (:policy :fast-safe)
  (:vop-var vop)
  (:generator 3
    (let* ((*location-context* (unless (eq type 'fixnum)
                                 type))
           (error (generate-error-code vop 'sb-kernel::negate-overflow-error x)))
      (inst mov temp 9223372036854775808)
      (inst cmp x temp)
      (inst jmp :a error)
      (move r x)
      (inst neg r))))

(define-vop (overflow-negate-signed=>unsigned)
  (:translate overflow-negate)
  (:args (x :scs (signed-reg)))
  (:arg-types signed-num)
  (:info type)
  (:results (r :scs (unsigned-reg)))
  (:result-types unsigned-num)
  (:policy :fast-safe)
  (:vop-var vop)
  (:generator 3
    (let* ((*location-context* (unless (eq type 'fixnum)
                                 type))
           (error (generate-error-code vop 'sb-kernel::negate-overflow-error x)))
      (inst test x x)
      (inst jmp :g error)
      (inst mov r x)
      (inst neg r))))

(define-vop (overflow-negate-t)
  (:translate overflow-negate)
  (:args (x :scs (any-reg descriptor-reg)))
  (:arg-types  (:or t tagged-num))
  (:arg-refs x-ref)
  (:info type)
  (:results (r :scs (any-reg) :from :load))
  (:result-types tagged-num)
  (:policy :fast-safe)
  (:vop-var vop)
  (:check-type x)
  (:generator 10
    (let* ((*location-context* (unless (eq type 'fixnum)
                                 type))
           (error (generate-error-code vop 'sb-kernel::negate-overflow-error x))
           (signed (types-equal-or-intersect (specifier-type type)
                                             ;; Only one sb64 value can negate into a fixnum
                                             (specifier-type `(eql ,most-negative-fixnum)))))
      (when signed
        (assemble (:elsewhere)
          start
          (setf signed start)
          (unless (fixnum-or-other-pointer-tn-ref-p x-ref t)
            (test-type x r error t (other-pointer-lowtag) :value-tn-ref x-ref))
          (inst cmp :qword (object-slot-ea x 0 other-pointer-lowtag) (bignum-header-for-length 1))
          (inst jmp :ne ERROR)
          (inst mov r (- most-negative-fixnum))
          (inst cmp (object-slot-ea x bignum-digits-offset other-pointer-lowtag) r)
          (inst jmp :ne error)
          (inst shl r n-fixnum-tag-bits)
          (inst jmp DONE)))
      (generate-fixnum-test x)
      (inst jmp :nz (or signed error))
      (move r x)
      (inst neg r)
      (inst jmp :o error))
    DONE))

(define-vop (overflow-ash-unsigned)
  (:translate overflow-ash)
  (:args (number :scs (unsigned-reg))
         (amount :scs (unsigned-reg signed-reg immediate)))
  (:arg-types unsigned-num untagged-num)
  (:arg-refs nil amount-ref)
  (:info type)
  (:temporary (:sc signed-reg :offset rcx-offset) ecx)
  (:temporary (:sc unsigned-reg) temp)
  (:results (result :scs (unsigned-reg) :from :load))
  (:result-types unsigned-num)
  (:policy :fast-safe)
  (:vop-var vop)
  (:variant-vars signed)
  (:generator 3
    (let* ((*location-context* (unless (eq type 'fixnum)
                                 type))
           (amount-error amount)
           (error (generate-error-code+
                   (when (sc-is amount immediate)
                     (setf amount (tn-value amount))
                     (cond ((typep amount 'sc-offset)
                            (setf amount-error (make-sc+offset immediate-sc-number amount))
                            nil)
                           (t
                            (setf amount-error
                                  (make-random-tn (sc-or-lose (if (typep amount 'word)
                                                                  'unsigned-reg
                                                                  'signed-reg))
                                                  (tn-offset temp)))

                            (lambda ()
                              (inst mov temp amount)))))
                   vop 'sb-kernel::ash-overflow2-error number amount-error))
           (amount-width (if (csubtypep (tn-ref-type amount-ref)
                                        (specifier-type `(signed-byte 32)))
                             :dword
                             :qword))
           (fits (csubtypep (tn-ref-type amount-ref)
                            (specifier-type `(integer -63 63)))))
      (when signed
        (inst test number number)
        (inst jmp :s error))
      (cond ((numberp amount)
             (cond ((< amount -63)
                    (zeroize result))
                   ((minusp amount)
                    (move result number)
                    (inst shr result amount))
                   ((> amount 63)
                    (inst test number number)
                    (inst jmp :nz error)
                    (move result number))
                   ((zerop amount)
                    (move result number))
                   (t
                    (move result number)
                    (inst shl result amount)
                    (cond ((= amount 1)
                           (inst jmp :c error))
                          (t
                           (move temp number)
                           (inst shr temp (- 64 amount))
                           (inst jmp :nz error))))))
            (t
             (assemble ()
               (move result number)
               (move ecx amount amount-width)
               (unless (csubtypep (tn-ref-type amount-ref)
                                  (specifier-type 'unsigned-byte))
                 (assemble ()
                   (inst test amount-width ecx ecx)
                   (inst jmp :ns POSITIVE)
                   (inst neg amount-width ecx)
                   (unless fits
                     (inst cmp amount-width ecx 63)
                     (inst jmp :be OKAY)
                     (zeroize result))
                   OKAY
                   (inst shr result :cl)
                   (inst jmp DONE)))
               POSITIVE
               (unless fits
                 (inst test number number)
                 (inst jmp :z done)
                 (inst cmp amount-width ecx n-word-bits)
                 (inst jmp :ge error))
               (inst shl result :cl)
               (inst neg :dword ecx)
               (move temp number)
               (inst shr temp :cl)
               (inst jmp :nz error)))))
    done))

(define-vop (overflow-ash-signed=>unsigned overflow-ash-unsigned)
  (:translate overflow-ash)
  (:args (number :scs (signed-reg))
         (amount :scs (unsigned-reg signed-reg immediate)))
  (:arg-types signed-num untagged-num)
  (:variant t)
  (:variant-cost 4))

(define-vop (overflow-ash-signed)
  (:translate overflow-ash)
  (:args (number :scs (signed-reg))
         (amount :scs (unsigned-reg signed-reg immediate)))
  (:arg-types signed-num untagged-num)
  (:arg-refs nil amount-ref)
  (:info type)
  (:temporary (:sc signed-reg :offset rcx-offset) ecx)
  (:temporary (:sc unsigned-reg) temp)
  (:results (result :scs (signed-reg) :from :load))
  (:result-types signed-num)
  (:policy :fast-safe)
  (:vop-var vop)
  (:variant-vars type-check)
  (:variant nil)
  (:generator 3
    (let* ((*location-context* (unless (eq type 'fixnum)
                                 type))
           (amount-error amount)
           (error (generate-error-code+
                   (when (sc-is amount immediate)
                     (setf amount (tn-value amount))
                     (cond ((typep amount 'sc-offset)
                            (setf amount-error (make-sc+offset immediate-sc-number amount))
                            nil)
                           (t
                            (setf amount-error
                                  (make-random-tn (sc-or-lose (if (typep amount 'word)
                                                                  'unsigned-reg
                                                                  'signed-reg))
                                                  (tn-offset temp)))

                            (lambda ()
                              (inst mov temp amount)))))
                   vop 'sb-kernel::ash-overflow2-error number amount-error))
           (amount-width (if (csubtypep (tn-ref-type amount-ref)
                                        (specifier-type `(signed-byte 32)))
                             :dword
                             :qword))
           (fits (csubtypep (tn-ref-type amount-ref)
                            (specifier-type `(integer -63 63)))))
      (when type-check
        (generate-fixnum-test number)
        (inst jmp :nz error))
      (cond ((numberp amount)
             (cond ((minusp amount)
                    (move result number)
                    (inst sar result (min (- amount) 63)))
                   ((> amount 63)
                    (inst test number number)
                    (inst jmp :nz error)
                    (move result number))
                   ((zerop amount)
                    (move result number))
                   ((= amount 63)
                    (inst lea result (ea 1 number))
                    (inst cmp result 2)
                    (inst jmp :ae error)
                    (move result number)
                    (inst shl result 63))
                   ((typep (ash 1 amount) '(signed-byte 32))
                    (inst imul result number (ash 1 amount))
                    (inst jmp :o error))
                   (t
                    (inst mov  result (ash 1 amount))
                    (inst imul result number)
                    (inst jmp :o error))))
            (t
             (assemble ()
               (move result number)
               (move ecx amount amount-width)
               (unless (csubtypep (tn-ref-type amount-ref)
                                  (specifier-type 'unsigned-byte))
                 (assemble ()
                   (inst test amount-width ecx ecx)
                   (inst jmp :ns POSITIVE)
                   (inst neg amount-width ecx)
                   (unless fits
                     (inst cmp amount-width ecx 63)
                     (inst jmp :be OKAY)
                     (inst mov :byte ecx 63))
                   OKAY
                   (inst sar result :cl)
                   (inst jmp DONE)))
               POSITIVE

               (unless fits
                 (inst test number number)
                 (inst jmp :z done)
                 (inst cmp amount-width ecx n-word-bits)
                 (inst jmp :ge error))
               (inst shl result :cl)
               (move temp result)
               (inst sar temp :cl)
               (inst cmp temp number)
               (inst jmp :ne error)))))
    done))

(define-vop (overflow-ash-fixnum overflow-ash-signed)
  (:translate overflow-ash)
  (:args (number :scs (any-reg))
         (amount :scs (unsigned-reg immediate)))
  (:arg-types tagged-num unsigned-num)
  (:results (result :scs (any-reg) :from :load))
  (:result-types tagged-num)
  (:variant-cost 2))

(define-vop (overflow-ash-t overflow-ash-fixnum)
  (:args (number :scs (any-reg descriptor-reg))
         (amount :scs (unsigned-reg signed-reg immediate)))
  (:arg-types (:or t tagged-num) unsigned-num)
  (:variant t)
  (:variant-cost 10)
  (:check-type number))

(define-vop (overflow+t)
  (:translate overflow+)
  (:args (x :scs (any-reg descriptor-reg))
         (y :scs (any-reg (immediate
                           (typep (tn-value tn) 'sc-offset)))))
  (:arg-types (:or t tagged-num) tagged-num)
  (:arg-refs x-ref)
  (:info type)
  (:temporary (:sc unsigned-reg :unused-if (or (atom type)
                                               (and (sc-is y immediate)
                                                    (typep (tn-value y) 'sc-offset))))
              temp)
  (:results (r :scs (any-reg) :from :load))
  (:result-types tagged-num)
  (:policy :fast-safe)
  (:vop-var vop)
  (:check-type x)
  (:generator 2
    (let* ((signed-p (and (typep type '(cons (eql :signed)))
                          (pop type)))
           (*location-context* (unless (eq type 'fixnum)
                                 type))
           (error (generate-error-code vop 'sb-kernel::add-overflow2-error x y)))
      (if signed-p
          (let* ((immediate (and (sc-is y immediate)
                                 (tn-value y)))
                 signed)
            (if immediate
                (setf temp r)
                (inst mov r y))
            (assemble (:elsewhere)
              start
              (setf signed start)
              (unless (fixnum-or-other-pointer-tn-ref-p x-ref t)
                (test-type x temp error t (other-pointer-lowtag)))
              (inst cmp :qword (object-slot-ea x 0 other-pointer-lowtag) (bignum-header-for-length 1))
              (inst jmp :ne ERROR)
              (cond (immediate
                     (loadw r x bignum-digits-offset other-pointer-lowtag)
                     (inst add r immediate))
                    (t
                     (inst sar r n-fixnum-tag-bits)
                     (inst add r (object-slot-ea x bignum-digits-offset other-pointer-lowtag))))
              (inst jmp :o ERROR)
              (inst shl r 1)
              (inst jmp :o ERROR)
              (inst jmp DONE))

            (generate-fixnum-test x)
            (inst jmp :nz signed)
            (cond (immediate
                   (move r x)
                   (inst add r (fixnumize immediate)))
                  (t
                   (inst add r x)))
            (inst jmp :o ERROR))

          (progn
            (unless (csubtypep (tn-ref-type x-ref) (specifier-type 'fixnum))
              (generate-fixnum-test x)
              (inst jmp :nz error))
            (move r x)
            (inst add r (sc-case y
                          (any-reg y)
                          (t
                           (fixnumize (tn-value y)))))
            (inst jmp :o error))))
    DONE))

(define-vop (overflow-t overflow+t)
  (:temporary (:sc unsigned-reg) temp)
  (:translate overflow-)
  (:generator 2
    (let* ((signed-p (and (typep type '(cons (eql :signed)))
                          (pop type)))
           (*location-context* (unless (eq type 'fixnum)
                                 type))
           (error (generate-error-code vop 'sb-kernel::sub-overflow2-error x y)))
      (if signed-p
          (let* ((immediate (and (sc-is y immediate)
                                 (tn-value y)))
                 signed)
            (assemble (:elsewhere)
              start
              (setf signed start)
              (unless (fixnum-or-other-pointer-tn-ref-p x-ref t)
                (test-type x temp error t (other-pointer-lowtag)))
              (inst cmp :qword (object-slot-ea x 0 other-pointer-lowtag) (bignum-header-for-length 1))
              (inst jmp :ne ERROR)
              (loadw r x bignum-digits-offset other-pointer-lowtag)
              (inst sub r (cond (immediate)
                                (t
                                 (move temp y)
                                 (inst sar temp 1)
                                 temp)))
              (inst jmp :o ERROR)
              (inst shl r 1)
              (inst jmp :o ERROR)
              (inst jmp DONE))

            (generate-fixnum-test x)
            (inst jmp :nz signed)
            (inst mov r x)
            (inst sub r (if immediate
                            (fixnumize immediate)
                            y))
            (inst jmp :o ERROR))

          (progn
            (unless (csubtypep (tn-ref-type x-ref) (specifier-type 'fixnum))
              (generate-fixnum-test x)
              (inst jmp :nz error))
            (move r x)
            (inst sub r (sc-case y
                          (any-reg y)
                          (t
                           (fixnumize (tn-value y)))))
            (inst jmp :o error))))
    DONE))

(define-vop (overflow-t-y overflow-t)
  (:args (x :scs (any-reg (immediate
                           (typep (tn-value tn) 'sc-offset))))
         (y :scs (any-reg descriptor-reg)))
  (:arg-types tagged-num (:or t tagged-num))
  (:arg-refs nil y-ref)
  (:check-type y)
  (:generator 2
    (let* ((signed-p (and (typep type '(cons (eql :signed)))
                          (pop type)))
           (*location-context* (unless (eq type 'fixnum)
                                 type))
           (error (generate-error-code vop 'sb-kernel::sub-overflow2-error x y))
           (x (if (sc-is x immediate)
                  (fixnumize (tn-value x))
                  x)))
      (if signed-p
          (let (signed)
            (assemble (:elsewhere)
              start
              (setf signed start)
              (unless (fixnum-or-other-pointer-tn-ref-p y-ref t)
                (test-type y temp error t (other-pointer-lowtag)))
              (inst cmp :qword (object-slot-ea y 0 other-pointer-lowtag) (bignum-header-for-length 1))
              (inst jmp :ne ERROR)
              (inst sar r 1)
              (inst sub r (object-slot-ea y bignum-digits-offset other-pointer-lowtag))
              (inst jmp :o ERROR)
              (inst shl r 1)
              (inst jmp :o ERROR)
              (inst jmp DONE))

            (inst mov r x)
            (generate-fixnum-test y)
            (inst jmp :nz signed)
            (inst sub r y)
            (inst jmp :o ERROR))
          (progn
            (unless (csubtypep (tn-ref-type y-ref) (specifier-type 'fixnum))
              (generate-fixnum-test y)
              (inst jmp :nz error))
            (inst mov r x)
            (inst sub r y)
            (inst jmp :o error))))
    DONE))

(define-vop (overflow*t)
  (:translate overflow*)
  (:args (x :scs (any-reg descriptor-reg))
         (y :scs (signed-reg)))
  (:arg-types (:or t tagged-num) tagged-num)
  (:arg-refs x-ref)
  (:info type)
  (:results (r :scs (any-reg) :from :load))
  (:result-types tagged-num)
  (:policy :fast-safe)
  (:vop-var vop)
  (:check-type x)
  (:generator 2
    (let* ((*location-context* (unless (eq type 'fixnum)
                                 type))
           (error (generate-error-code vop 'sb-kernel::mul-overflow2-error x y)))
      (unless (csubtypep (tn-ref-type x-ref) (specifier-type 'fixnum))
        (generate-fixnum-test x)
        (inst jmp :nz error))
      (move r x)
      (inst imul r y)
      (inst jmp :o error))))


(define-vop (fast-truncate/fixnum=>fixnum fast-safe-arith-op)
  (:translate truncate)
  (:args (x :scs (any-reg) :target eax)
         (y :scs (any-reg control-stack)))
  (:arg-refs nil y-ref)
  (:arg-types tagged-num tagged-num)
  (:temporary (:sc signed-reg :offset rax-offset :target quo
               :from (:argument 0) :to (:result 0)) eax)
  (:temporary (:sc unsigned-reg :offset rdx-offset :target rem
               :from (:argument 0) :to (:result 1)) edx)
  (:results (quo :scs (any-reg))
            (rem :scs (any-reg)))
  (:result-types tagged-num tagged-num)
  (:note "inline fixnum arithmetic")
  (:vop-var vop)
  (:save-p :compute-only)
  (:generator 31
    (when (types-equal-or-intersect (tn-ref-type y-ref)
                                    (specifier-type '(eql 0)))
      (if (sc-is y signed-reg)
          (inst test y y)               ; smaller instruction
          (inst cmp y 0))
      (inst jmp :e (generate-error-code vop 'division-by-zero-error x)))
    (move eax x)
    (inst cqo)
    (inst idiv y)
    (if (location= quo eax)
        (inst shl eax n-fixnum-tag-bits)
        (if (= n-fixnum-tag-bits 1)
            (inst lea quo (ea eax eax))
            (inst lea quo (ea nil eax (ash 1 n-fixnum-tag-bits)))))
    (move rem edx)))

(define-vop (fast-truncate-c/fixnum=>fixnum fast-safe-arith-op)
  (:translate truncate)
  (:args (x :scs (any-reg) :target rax))
  (:info y)
  (:arg-types tagged-num (:constant fixnum))
  (:temporary (:sc signed-reg :offset rax-offset :target quo
                   :from :argument :to (:result 0)) rax)
  (:temporary (:sc any-reg :offset rdx-offset :target rem
                   :from :eval :to (:result 1)) rdx)
  (:temporary (:sc any-reg :from :eval :to :result) y-arg)
  (:results (quo :scs (any-reg))
            (rem :scs (any-reg)))
  (:optional-results quo)
  (:result-types tagged-num tagged-num)
  (:note "inline fixnum arithmetic")
  (:vop-var vop)
  (:generator 30
    (move rax x)
    (inst cqo)
    (inst mov y-arg (fixnumize y))
    (inst idiv y-arg)
    (unless (eq (tn-kind quo) :unused)
      (if (location= quo rax)
          (inst shl rax n-fixnum-tag-bits)
          (if (= n-fixnum-tag-bits 1)
              (inst lea quo (ea rax rax))
              (inst lea quo (ea nil rax (ash 1 n-fixnum-tag-bits))))))
    (move rem rdx)))

(define-vop (fast-truncate/unsigned=>unsigned fast-safe-arith-op)
  (:translate truncate)
  (:args (x :scs (unsigned-reg) :target eax)
         (y :scs (unsigned-reg signed-stack)))
  (:arg-types unsigned-num unsigned-num)
  (:arg-refs nil y-ref)
  (:temporary (:sc unsigned-reg :offset rax-offset :target quo
               :from (:argument 0) :to (:result 0)) eax)
  (:temporary (:sc unsigned-reg :offset rdx-offset :target rem
                   :from (:argument 0) :to (:result 1)) edx)
  (:results (quo :scs (unsigned-reg))
            (rem :scs (unsigned-reg)))
  (:result-types unsigned-num unsigned-num)
  (:note "inline (unsigned-byte 64) arithmetic")
  (:vop-var vop)
  (:save-p :compute-only)
  (:generator 33
    (when (types-equal-or-intersect (tn-ref-type y-ref)
                                    (specifier-type '(eql 0)))
      (if (sc-is y signed-reg)
          (inst test y y)               ; smaller instruction
          (inst cmp y 0))
      (inst jmp :e (generate-error-code vop 'division-by-zero-error x)))
    (move eax x)
    (zeroize edx)
    (inst div y)
    (move quo eax)
    (move rem edx)))

(define-vop (fast-truncate-c/unsigned=>unsigned fast-safe-arith-op)
  (:translate truncate)
  (:args (x :scs (unsigned-reg) :target eax))
  (:info y)
  (:arg-types unsigned-num (:constant (unsigned-byte 64)))
  (:temporary (:sc unsigned-reg :offset rax-offset :target quo
                   :from :argument :to (:result 0)) eax)
  (:temporary (:sc unsigned-reg :offset rdx-offset :target rem
                   :from :eval :to (:result 1)) edx)
  (:temporary (:sc unsigned-reg :from :eval :to :result) y-arg)
  (:results (quo :scs (unsigned-reg))
            (rem :scs (unsigned-reg)))
  (:result-types unsigned-num unsigned-num)
  (:note "inline (unsigned-byte 64) arithmetic")
  (:vop-var vop)
  (:generator 32
    (move eax x)
    (zeroize edx)
    (inst mov y-arg y)
    (inst div y-arg)
    (move quo eax)
    (move rem edx)))

(define-vop (fast-truncate/signed=>signed fast-safe-arith-op)
  (:translate truncate)
  (:args (x :scs (signed-reg) :target eax)
         (y :scs (signed-reg signed-stack)))
  (:arg-refs nil y-ref)
  (:arg-types signed-num signed-num)
  (:temporary (:sc signed-reg :offset rax-offset :target quo
                   :from (:argument 0) :to (:result 0)) eax)
  (:temporary (:sc signed-reg :offset rdx-offset :target rem
                   :from (:argument 0) :to (:result 1)) edx)
  (:results (quo :scs (signed-reg))
            (rem :scs (signed-reg)))
  (:result-types signed-num signed-num)
  (:note "inline (signed-byte 64) arithmetic")
  (:vop-var vop)
  (:save-p :compute-only)
  (:generator 33
    (when (types-equal-or-intersect (tn-ref-type y-ref)
                                    (specifier-type '(eql 0)))
      (if (sc-is y signed-reg)
          (inst test y y)               ; smaller instruction
          (inst cmp y 0))
      (inst jmp :e (generate-error-code vop 'division-by-zero-error x)))
    (move eax x)
    (inst cqo)
    (inst idiv y)
    (move quo eax)
    (move rem edx)))

(define-vop (fast-truncate-c/signed=>signed fast-safe-arith-op)
  (:translate truncate)
  (:args (x :scs (signed-reg) :target eax))
  (:info y)
  (:arg-types signed-num (:constant (signed-byte 64)))
  (:temporary (:sc signed-reg :offset rax-offset :target quo
                   :from :argument :to (:result 0)) eax)
  (:temporary (:sc signed-reg :offset rdx-offset :target rem
                   :from :eval :to (:result 1)) edx)
  (:temporary (:sc signed-reg :from :eval :to :result) y-arg)
  (:results (quo :scs (signed-reg))
            (rem :scs (signed-reg)))
  (:result-types signed-num signed-num)
  (:note "inline (signed-byte 64) arithmetic")
  (:vop-var vop)
  (:generator 32
    (move eax x)
    (inst cqo)
    (inst mov y-arg y)
    (inst idiv y-arg)
    (move quo eax)
    (move rem edx)))

(define-vop (truncate-mod64 fast-truncate/signed=>signed)
  (:translate truncate-mod64)
  (:results (quo :scs (unsigned-reg))
            (rem :scs (signed-reg)))
  (:result-types unsigned-num signed-num)
  (:optional-results rem)
  (:generator 33
    (when (types-equal-or-intersect (tn-ref-type y-ref)
                                    (specifier-type '(eql 0)))
      (if (sc-is y signed-reg)
          (inst test y y)
          (inst cmp y 0))
      (inst jmp :e (generate-error-code vop 'division-by-zero-error x)))
    (move eax x)

    (inst cmp y -1)
    (inst jmp :ne NO-OVERFLOW)
    (inst neg eax)
    (unless (eq (tn-kind rem) :unused)
      (zeroize rem))
    (inst jmp DONE)

    NO-OVERFLOW
    (inst cqo)
    (inst idiv y)
    (unless (eq (tn-kind rem) :unused)
      (move rem edx))
    DONE
    (move quo eax)))

(define-vop (fast-truncate/signed-unsigned=>signed fast-safe-arith-op)
  (:translate truncate)
  (:args (x :scs (signed-reg (immediate
                              (minusp (tn-value tn)))) :to :result)
         (y :scs (unsigned-reg unsigned-stack) :to :result))
  (:arg-refs x-ref y-ref)
  (:arg-types signed-num unsigned-num)
  (:temporary (:sc signed-reg :offset rax-offset) eax)
  (:temporary (:sc signed-reg :offset rdx-offset) edx)
  (:results (quo :scs (signed-reg))
            (rem :scs (signed-reg)))
  (:result-types signed-num signed-num)
  (:optional-results quo rem)
  (:note "inline (signed-byte 64) arithmetic")
  (:vop-var vop)
  (:save-p :compute-only)
  (:generator 34
    (if (sc-is x immediate)
        (inst mov eax (- (tn-value x)))
        (move eax x))
    (zeroize edx)
    (let ((zero (when (types-equal-or-intersect (tn-ref-type y-ref)
                                                (specifier-type '(eql 0)))
                  (generate-error-code+
                   (when (sc-is x immediate)
                     (lambda ()
                       (inst neg eax)))
                   vop 'division-by-zero-error eax))))
     (cond
       ((csubtypep (tn-ref-type x-ref) (specifier-type '(integer * 0)))
        (unless (sc-is x immediate)
          (inst neg eax))
        (when zero
          (if (sc-is y unsigned-reg)
              (inst test y y)
              (inst cmp y 0))
          (inst jmp :e zero))
        (inst div y))
       (t
        (assemble ()
          (inst test eax eax)
          (inst jmp :ge POS1)
          (inst neg eax)
          POS1
          (when zero
            (if (sc-is y unsigned-reg)
                (inst test y y)
                (inst cmp y 0))
            (inst jmp :e zero))
          (inst div y)

          (inst test x x)
          (inst jmp :ge POS2)))))

    (unless (eq (tn-kind quo) :unused)
      (inst neg eax))
    (unless (eq (tn-kind rem) :unused)
         (inst neg edx))
    POS2
    (unless (eq (tn-kind quo) :unused)
      (move quo eax))
    (unless (eq (tn-kind rem) :unused)
      (move rem edx))))

(defun power-of-two-p (x)
  (and (typep x 'signed-word)
       (let ((abs (abs x)))
         (and (> abs 1)
              (= (logcount abs) 1)))))

(define-vop (truncate/signed-power-of-two fast-safe-arith-op)
  (:translate truncate)
  (:args (x :scs (signed-reg) :to :result))
  (:arg-types signed-num (:constant (satisfies power-of-two-p)))
  (:info y)
  (:temporary (:sc unsigned-reg) temp)
  (:temporary (:sc unsigned-reg
               :unused-if
               (not (and (eq (tn-kind quo) :unused)
                         (not (typep (1- (abs y)) '(signed-byte 32))))))
              temp2)
  (:results (quo :scs (signed-reg) :from :eval)
            (rem :scs (signed-reg) :from :eval))
  (:optional-results quo rem)
  (:result-types signed-num signed-num)
  (:note "inline (signed-byte 64) arithmetic")
  (:vop-var vop)
  (:generator 10
    (let* ((abs-y (abs y))
           (shift (1- (integer-length abs-y))))
      (cond ((eq (tn-kind quo) :unused)
             (move temp x)
             (unless (= shift 1)
               (inst sar temp 63))
             (inst shr temp (- 64 shift))
             (inst lea rem (ea x temp))
             (cond ((typep (1- abs-y) '(signed-byte 32))
                    (inst and :dword rem (1- abs-y)))
                   (t
                    (inst mov temp2 (1- abs-y))
                    (inst and rem temp2)))
             (inst sub rem temp))
            (t
             (cond ((= abs-y 2)
                    (inst mov quo x)
                    (inst shr quo 63)
                    (inst add quo x))
                   ((typep (1- abs-y) '(signed-byte 32))
                    (inst lea quo (ea (1- abs-y) x))
                    (inst test x x)
                    (inst cmov :ns quo x))
                   (t
                    (cond ((eq (tn-kind rem) :unused)
                           (inst mov quo (1- abs-y)))
                          (t
                           (inst mov temp (- abs-y))
                           (inst mov quo temp)
                           (inst not quo)))
                    (inst add quo x)
                    (inst test x x)
                    (inst cmov :ns quo x)))
             (unless (eq (tn-kind rem) :unused)
               (cond ((typep (- abs-y) '(signed-byte 32))
                      (inst mov temp quo)
                      (inst and temp (- abs-y)))
                     (t
                      (inst and temp quo)))
               (inst mov rem x)
               (inst sub rem temp))
             (inst sar quo shift)
             (when (minusp y)
               (inst neg quo)))))))

;;;; Shifting
(macrolet ((encodable-as-lea ()
             `(and (gpr-tn-p number) (gpr-tn-p result)
                   (not (location= number result))
                   (member amount '(1 2 3))))
           (generate-lea ()
             `(case amount
                (1 (inst lea result (ea number number)))
                (2 (inst lea result (ea nil number 4)))
                (3 (inst lea result (ea nil number 8)))))
           (with-shift-operands (&body body)
             ;; If the initial "MOVE result number" is a legal instruction,
             ;; then we're OK; otherwise use the temp reg to do the shift.
             `(multiple-value-bind (save result)
                  (if (or (location= number result) (gpr-tn-p number) (gpr-tn-p result))
                      (values nil result)
                      (values result temp))
                (move result number)
                (assemble ()
                 ,@body)
                (when save (inst mov save result)))))

(define-vop (fast-ash-c/fixnum=>fixnum)
  (:translate ash)
  (:policy :fast-safe)
  (:args (number :scs (any-reg control-stack) :target result))
  (:info amount)
  (:arg-types tagged-num (:constant integer))
  (:results (result :scs (any-reg control-stack)))
  (:result-types tagged-num)
  (:note "inline ASH")
  (:temporary (:sc unsigned-reg) temp)
  (:generator 2
    (cond ((= amount 0) (bug "shifting by 0"))
          ((>= amount 64) ; shifting left (zero fill)
           (zeroize result))
          ((encodable-as-lea) (generate-lea))
          (t
           (with-shift-operands
            (cond ((< -64 amount 64)
                   ;; this code is used both in ASH and ASH-MODFX, so
                   ;; be careful
                   (if (plusp amount)
                       (inst shl result amount)
                       (progn
                         (inst sar result (- amount))
                         (inst and result (lognot fixnum-tag-mask)))))
                  ;; shifting right (sign fill)
                  (t (move result number)
                     (inst sar result 63)
                     (inst and result (lognot fixnum-tag-mask)))))))))

(define-vop (fast-ash-left/fixnum=>fixnum)
  (:translate ash)
  (:args (number :scs (any-reg control-stack) :target result)
         (amount :scs (unsigned-reg) :target ecx))
  (:arg-types tagged-num unsigned-num)
  (:temporary (:sc unsigned-reg :offset rcx-offset :from (:argument 1)) ecx)
  (:results (result :scs (any-reg control-stack) :from (:argument 0)))
  (:result-types tagged-num)
  (:policy :fast-safe)
  (:note "inline ASH")
  (:temporary (:sc unsigned-reg) temp)
  (:generator 3
    (with-shift-operands
      (move ecx amount)
      ;; The result-type ensures us that this shift will not overflow.
      (inst shl result :cl))))

(define-vop (fast-ash-c/signed=>signed)
  (:translate ash)
  (:policy :fast-safe)
  (:args (number :scs (signed-reg signed-stack) :target result))
  (:info amount)
  (:arg-types signed-num (:constant integer))
  (:results (result :scs (signed-reg signed-stack)))
  (:result-types signed-num)
  (:note "inline ASH")
  (:temporary (:sc unsigned-reg) temp)
  (:generator 3
    (cond ((encodable-as-lea) (generate-lea))
          (t
           (with-shift-operands
            (cond ((plusp amount) (inst shl result amount))
                  (t (inst sar result (min 63 (- amount))))))))))

(define-vop (fast-ash-c/unsigned=>unsigned)
  (:translate ash)
  (:policy :fast-safe)
  (:args (number :scs (unsigned-reg unsigned-stack) :target result))
  (:info amount)
  (:arg-types unsigned-num (:constant integer))
  (:results (result :scs (unsigned-reg unsigned-stack)))
  (:result-types unsigned-num)
  (:note "inline ASH")
  (:temporary (:sc unsigned-reg) temp)
  (:generator 3
    (cond ((= amount 0) (bug "shifting by 0"))
          ((not (< -64 amount 64)) (zeroize result))
          ((encodable-as-lea) (generate-lea))
          (t
           (with-shift-operands
             (if (plusp amount)
                 (inst shl result amount)
                 (inst shr result (- amount))))))))

(define-vop (fast-ash-left/signed=>signed)
  (:translate ash)
  (:args (number :scs (signed-reg signed-stack) :target result)
         (amount :scs (unsigned-reg) :target ecx))
  (:arg-types signed-num positive-fixnum)
  (:temporary (:sc unsigned-reg :offset rcx-offset :from (:argument 1)) ecx)
  (:results (result :scs (signed-reg signed-stack) :from (:argument 0)))
  (:result-types signed-num)
  (:policy :fast-safe)
  (:note "inline ASH")
  (:temporary (:sc unsigned-reg) temp)
  (:generator 4
    (with-shift-operands
      (move ecx amount)
      (inst shl result :cl))))

(define-vop (fast-ash-left/unsigned=>unsigned)
  (:translate ash)
  (:args (number :scs (unsigned-reg unsigned-stack) :target result)
         (amount :scs (unsigned-reg) :target ecx))
  (:arg-types unsigned-num positive-fixnum)
  (:temporary (:sc unsigned-reg :offset rcx-offset :from (:argument 1)) ecx)
  (:results (result :scs (unsigned-reg unsigned-stack) :from (:argument 0)))
  (:result-types unsigned-num)
  (:policy :fast-safe)
  (:note "inline ASH")
  (:temporary (:sc unsigned-reg) temp)
  (:generator 4
    (with-shift-operands
      (move ecx amount)
      (inst shl result :cl))))

(define-vop (fast-ash-left/fixnum-modfx=>fixnum
             fast-ash-left/fixnum=>fixnum)
  (:translate ash-left-modfx)
  (:arg-refs nil amount-ref)
  (:generator 3
    (with-shift-operands
      (move ecx amount)
      (unless (csubtypep (tn-ref-type amount-ref)
                         (specifier-type '(mod 64)))
        (inst cmp amount 63)
        (inst jmp :be OKAY)
        (zeroize result))
      OKAY
      (inst shl result :cl))))

(define-vop (fast-ash-left-mod64-c/unsigned=>unsigned
             fast-ash-c/unsigned=>unsigned)
  (:translate ash-left-mod64))

(define-vop (fast-ash-left-modfx-c/fixnum=>fixnum
             fast-ash-c/fixnum=>fixnum)
  (:translate ash-left-modfx))

(define-vop (fast-ash-left/unsigned-mod64=>unsigned
             fast-ash-left/unsigned=>unsigned)
  (:translate ash-left-mod64)
  (:arg-refs nil amount-ref)
  (:generator 4
    (with-shift-operands
      (move ecx amount)
      (unless (csubtypep (tn-ref-type amount-ref)
                         (specifier-type '(mod 64)))
        (inst cmp amount 63)
        (inst jmp :be OKAY)
        (zeroize result))
      OKAY
      (inst shl result :cl))))

(define-vop (fast-%ash/right/unsigned)
  (:translate %ash/right)
  (:policy :fast-safe)
  (:args (number :scs (unsigned-reg unsigned-stack) :target result)
         (amount :scs (unsigned-reg) :target rcx))
  (:arg-types unsigned-num unsigned-num)
  (:results (result :scs (unsigned-reg unsigned-stack) :from (:argument 0)))
  (:result-types unsigned-num)
  (:temporary (:sc signed-reg :offset rcx-offset :from (:argument 1)) rcx)
  (:temporary (:sc unsigned-reg) temp)
  (:generator 4
    (with-shift-operands
      (move rcx amount)
      (inst shr result :cl))))

(define-vop (fast-%ash/right/signed)
  (:translate %ash/right)
  (:policy :fast-safe)
  (:args (number :scs (signed-reg signed-stack) :target result)
         (amount :scs (unsigned-reg) :target rcx))
  (:arg-types signed-num unsigned-num)
  (:results (result :scs (signed-reg signed-stack) :from (:argument 0)))
  (:result-types signed-num)
  (:temporary (:sc signed-reg :offset rcx-offset :from (:argument 1)) rcx)
  (:temporary (:sc unsigned-reg) temp)
  (:generator 4
    (with-shift-operands
      (move rcx amount)
      (inst sar result :cl))))

(define-vop (fast-%ash/right/fixnum)
  (:translate %ash/right)
  (:policy :fast-safe)
  (:args (number :scs (any-reg control-stack) :target result)
         (amount :scs (unsigned-reg) :target rcx))
  (:arg-types tagged-num unsigned-num)
  (:results (result :scs (any-reg control-stack) :from (:argument 0)))
  (:result-types tagged-num)
  (:temporary (:sc signed-reg :offset rcx-offset :from (:argument 1)) rcx)
  (:temporary (:sc unsigned-reg) temp)
  (:generator 3
    (with-shift-operands
      (move rcx amount)
      (inst sar result :cl)
      (inst and result (lognot fixnum-tag-mask)))))
) ; end MACROLET

(define-vop (fast-ash/unsigned=>unsigned)
  (:translate ash)
  (:policy :fast-safe)
  (:args (number :scs (unsigned-reg) :target result)
         (amount :scs (signed-reg) :target ecx))
  (:arg-types unsigned-num signed-num)
  (:results (result :scs (unsigned-reg) :from (:argument 0)))
  (:result-types unsigned-num)
  (:temporary (:sc signed-reg :offset rcx-offset :from (:argument 1)) ecx)
  (:arg-refs nil amount-ref)
  (:variant-vars check-amount signed)
  (:note "inline ASH")
  (:generator 5
    (let ((amount-width (if (csubtypep (tn-ref-type amount-ref)
                                       (specifier-type `(signed-byte 32)))
                            :dword
                            :qword)))
      (assemble ()
        (move result number)
        (move ecx amount amount-width)
        (inst test amount-width ecx ecx)
        (inst jmp :ns POSITIVE)
        (inst neg amount-width ecx)
        (unless (csubtypep (tn-ref-type amount-ref)
                           (specifier-type `(integer -63 *)))
          (inst cmp amount-width ecx 63)
          (inst jmp :be OKAY)
          (cond (signed
                 (inst mov :byte ecx 63))
                (t
                 (zeroize result))))
        OKAY
        (if signed
            (inst sar result :cl)
            (inst shr result :cl))
        (inst jmp DONE)

        POSITIVE
        (unless (or (not check-amount) ;; The result-type ensures us that this shift will not overflow.
                    (csubtypep (tn-ref-type amount-ref)
                               (specifier-type `(integer * 63))))
          (inst cmp amount-width ecx 63)
          (inst jmp :be STILL-OKAY)
          (zeroize result))
        STILL-OKAY
        (inst shl result :cl)

        DONE))))

(define-vop (fast-ash/signed=>signed
             fast-ash/unsigned=>unsigned)
  (:args (number :scs (signed-reg) :target result)
         (amount :scs (signed-reg) :target ecx))
  (:arg-types signed-num signed-num)
  (:results (result :scs (signed-reg) :from (:argument 0)))
  (:result-types signed-num)
  (:variant nil t))

(define-vop (fast-ash-modfx/signed=>signed
             fast-ash/signed=>signed)
  (:variant t t)
  (:translate ash-modfx))

(define-vop (fast-ash-modfx/unsigned=>signed
             fast-ash/unsigned=>unsigned)
  (:results (result :scs (signed-reg) :from (:argument 0)))
  (:result-types signed-num)
  (:variant t nil)
  (:translate ash-modfx)
  (:variant-cost 6))

(define-vop (fast-ash-mod64/unsigned=>unsigned
             fast-ash/unsigned=>unsigned)
  (:variant t nil)
  (:translate ash-mod64))

(define-vop (fast-ash-mod64/signed=>unsigned
             fast-ash/signed=>signed)
  (:results (result :scs (unsigned-reg)))
  (:result-types unsigned-num)
  (:variant t t)
  (:translate ash-mod64))

;;; Given an unsigned 32-bit dividend and magic numbers, compute the truncated quotient.
;;; The 2nd through 4th args are 'magic', 'add', 'shift'.
(defknown udiv32-via-multiply ((unsigned-byte 32)
                               (unsigned-byte 32) bit (integer 0 31))
  (unsigned-byte 32)
  (flushable))
(define-vop ()
  (:translate udiv32-via-multiply)
  (:policy :fast-safe)
  (:args (dividend :scs (unsigned-reg))
         (magic :scs (unsigned-reg))
         (add :scs (unsigned-reg))
         (shift :scs (unsigned-reg)))
  (:arg-types unsigned-num unsigned-num unsigned-num unsigned-num)
  (:results (quotient :scs (unsigned-reg)))
  (:result-types unsigned-num)
  (:temporary (:sc unsigned-reg :offset rcx-offset) rcx)
  (:temporary (:sc unsigned-reg) temp)
  (:generator 6
    (inst mov :dword temp dividend)
    (inst imul temp magic)
    (inst test :byte add add)
    (inst jmp :z no-add)
    (inst shr temp 32) ; temp is now the quotient 'q'
    (inst mov :dword rcx dividend)
    (inst sub :dword rcx temp) ; compute (n - quotient)
    (inst shr :dword rcx 1)
    (inst lea :dword temp (ea rcx temp)) ; add 'q'
    (inst lea :dword rcx (ea -1 shift))
    (inst shr :dword temp :cl) ; shift by s-1
    (inst jmp OUT)
    NO-ADD
    (inst lea :dword rcx (ea 32 shift))
    (inst shr temp :cl)
    OUT
    (inst mov :dword quotient temp)))

;;; Given an unsigned 32-bit dividend and divisor, compute the remainder
;;; using the Granlund & Montgomery approach.
;;; The inputs to this vop are the dividend, the divisor, and the <m,a,s>
;;; components of the magic.
(defknown urem32-via-multiply ((unsigned-byte 32) (unsigned-byte 32)
                               (unsigned-byte 32) bit (integer 0 31))
  (unsigned-byte 32)
  (flushable))
(define-vop ()
  (:translate urem32-via-multiply)
  (:policy :fast-safe)
  (:args (dividend :scs (unsigned-reg))
         (divisor :scs (unsigned-reg))
         (magic :scs (unsigned-reg))
         (add :scs (unsigned-reg immediate))
         (shift :scs (unsigned-reg)))
  (:arg-types unsigned-num unsigned-num unsigned-num unsigned-num unsigned-num)
  (:results (remainder :scs (unsigned-reg)))
  (:result-types unsigned-num)
  (:temporary (:sc unsigned-reg :offset rcx-offset) rcx)
  (:temporary (:sc unsigned-reg :offset rax-offset) rax)
  (:temporary (:sc unsigned-reg :offset rdx-offset) rdx)
  (:ignore rdx)
  (:generator 10
    (inst mov :dword rax dividend)
    (inst imul rax magic)
    (cond ((sc-is add immediate)
           (aver (= (tn-value add) 0))) ; for now I only need add=0
          (t
           (inst test :byte add add)
           (inst jmp :z no-add)
           (inst shr rax 32) ; rax is now the quotient 'q'
           (inst mov :dword rcx dividend)
           (inst sub :dword rcx rax) ; compute (n - quotient)
           (inst shr :dword rcx 1)
           (inst lea :dword rax (ea rcx rax)) ; add 'q'
           (inst lea :dword rcx (ea -1 shift))
           (inst shr :dword rax :cl) ; shift by s-1
           (inst jmp CALC-REMAINDER)))
    NO-ADD
    (inst lea :dword rcx (ea 32 shift))
    (inst shr rax :cl)
    CALC-REMAINDER
    ;; EAX is the quotient. Multiply it by the divisor, and then take
    ;; the difference of that and the divisor.
    (inst mul :dword divisor) ; clobbers EDX too
    (inst neg rax)
    (inst lea remainder (ea dividend rax))))

;;; Given a dividend, scaled reciprocal-of-divisor, and divisor (in that order)
;;; compute a remainder using the approach of Lemire, Kaser, Kurz.
;;;
(macrolet
    ((define-fastrem (bits opsize
                           &aux (name (symbolicate "FASTREM-" bits)))
       `(define-vop (,name)
          (:translate ,name)
          (:policy :fast-safe)
          (:args (dividend :scs (unsigned-reg) :target rax)
                 (c :scs (unsigned-reg))
                 (divisor :scs (unsigned-reg)))
          (:arg-types unsigned-num unsigned-num unsigned-num)
          (:results (remainder :scs (unsigned-reg)))
          (:result-types unsigned-num)
          (:temporary (:sc unsigned-reg :offset rax-offset
                       :from (:argument 0) :to (:result 0)) rax)
          (:temporary (:sc unsigned-reg :offset rdx-offset
                       :from (:argument 0) :to (:result 0)) rdx)
          (:generator 10
            (move rax dividend ,opsize)
            (inst mul ,opsize c) ; result to rDX:rAX (but we expressly drop all bits from rDX)
            (inst mul ,opsize divisor) ; new we want _only_ bits from rDX
            (move remainder rdx ,opsize)))))
  (define-fastrem 32 :dword)
  (define-fastrem 64 :qword))

(in-package "SB-C")

(defknown %lea (integer integer (member 1 2 4 8 16) (signed-byte 64))
  integer
  (foldable flushable movable))

;;; FIXME: arg order should be (DISP BASE INDEX SCALE) to match EA constructor
(defun %lea (base index scale disp)
  (+ base (* index scale) disp))

(in-package "SB-VM")

(define-vop (%lea/unsigned=>unsigned)
  (:translate %lea)
  (:policy :fast-safe)
  (:args (base :scs (unsigned-reg))
         (index :scs (unsigned-reg)))
  (:info scale disp)
  (:arg-types unsigned-num unsigned-num
              (:constant (member 1 2 4 8))
              (:constant (signed-byte 64)))
  (:results (r :scs (unsigned-reg)))
  (:result-types unsigned-num)
  (:generator 5
    (inst lea r (ea disp base index scale))))

(define-vop (%lea/signed=>signed)
  (:translate %lea)
  (:policy :fast-safe)
  (:args (base :scs (signed-reg))
         (index :scs (signed-reg)))
  (:info scale disp)
  (:arg-types signed-num signed-num
              (:constant (member 1 2 4 8))
              (:constant (signed-byte 64)))
  (:results (r :scs (signed-reg)))
  (:result-types signed-num)
  (:generator 4
    (inst lea r (ea disp base index scale))))

(define-vop (%lea/fixnum=>fixnum)
  (:translate %lea)
  (:policy :fast-safe)
  (:args (base :scs (any-reg))
         (index :scs (any-reg)))
  (:info scale disp)
  (:arg-types tagged-num tagged-num
              (:constant (member 1 2 4 8))
              (:constant (signed-byte 64)))
  (:results (r :scs (any-reg)))
  (:result-types tagged-num)
  (:generator 3
    (inst lea r (ea disp base index scale))))

;;; FIXME: before making knowledge of this too public, it needs to be
;;; fixed so that it's actually _faster_ than the non-CMOV version; at
;;; least on my Celeron-XXX laptop, this version is marginally slower
;;; than the above version with branches.  -- CSR, 2003-09-04
(define-vop (fast-cmov-ash/unsigned=>unsigned)
  (:translate ash)
  (:policy :fast-safe)
  (:args (number :scs (unsigned-reg) :target result)
         (amount :scs (signed-reg) :target ecx))
  (:arg-types unsigned-num signed-num)
  (:results (result :scs (unsigned-reg) :from (:argument 0)))
  (:result-types unsigned-num)
  (:temporary (:sc signed-reg :offset rcx-offset :from (:argument 1)) ecx)
  (:temporary (:sc any-reg :from (:eval 0) :to (:eval 1)) zero)
  (:note "inline ASH")
  (:guard (member :cmov *backend-subfeatures*))
  (:generator 4
    (move result number)
    (move ecx amount)
    (inst test ecx ecx)
    (inst jmp :ns POSITIVE)
    (inst neg ecx)
    (zeroize zero)
    (inst shr result :cl)
    (inst cmp ecx 63)
    (inst cmov :nbe result zero)
    (inst jmp DONE)

    POSITIVE
    ;; The result-type ensures us that this shift will not overflow.
    (inst shl result :cl)

    DONE))

(define-vop (signed-byte-64-len)
  (:translate integer-length)
  (:note "inline (signed-byte 64) integer-length")
  (:policy :fast-safe)
  (:args (arg :scs (signed-reg) :to :save))
  (:arg-refs arg-ref)
  (:arg-types signed-num)
  (:results (res :scs (unsigned-reg)))
  (:result-types unsigned-num)
  (:generator 28
    (let ((zerop (types-equal-or-intersect (tn-ref-type arg-ref)
                                           (specifier-type '(integer -1 0)))))
      (assemble ()
        (move res arg)
        (inst sar res 63)
        (inst xor res arg) ;; invert if negative
        POS
        (when zerop
          (inst jmp :z DONE))
        (inst bsr res res)
        (inst inc :dword res)
        DONE))))

(define-vop (unsigned-byte-64-len)
  (:translate integer-length)
  (:note "inline (unsigned-byte 64) integer-length")
  (:policy :fast-safe)
  (:args (arg :scs (unsigned-reg)))
  (:arg-refs arg-ref)
  (:arg-types unsigned-num)
  (:results (res :scs (unsigned-reg)))
  (:result-types unsigned-num)
  (:generator 26
    (let ((zerop (types-equal-or-intersect (tn-ref-type arg-ref)
                                           (specifier-type '(eql 0)))))
      (assemble ()
        (unless (location= res arg)
          ;; BSR leaves the target unmodified on zero, producing a dependency
          (zeroize res))
        (inst bsr res arg)
        (when zerop
          (inst jmp :z DONE))
        (inst inc :dword res)
        DONE))))

(define-vop (positive-fixnum-len)
  (:translate integer-length)
  (:note "inline positive fixnum integer-length")
  (:policy :fast-safe)
  (:args (arg :scs (any-reg)))
  (:arg-types positive-fixnum)
  (:results (res :scs (unsigned-reg)))
  (:result-types unsigned-num)
  (:arg-refs arg-ref)
  (:generator 24
    (let ((size (if (csubtypep (tn-ref-type arg-ref) (specifier-type '(unsigned-byte 31)))
                    :dword :qword)))
      (unless (location= res arg)
        ;; BSR leaves the target unmodified on zero
        (zeroize res))
      (inst bsr size res arg))))

(define-vop (fixnum-len)
  (:translate integer-length)
  (:note "inline fixnum integer-length")
  (:policy :fast-safe)
  (:args (arg :scs (any-reg) :to :save))
  (:arg-types tagged-num)
  (:results (res :scs (unsigned-reg)))
  (:result-types unsigned-num)
  (:generator 25
    (move res arg)
    (inst sar res 63)
    (inst xor res arg) ;; invert if negative
    (inst bsr res res)))

(define-vop ()
  (:translate count-trailing-zeros)
  (:policy :fast-safe)
  (:args (arg :scs (signed-reg unsigned-reg) :to :save))
  (:arg-types (:or signed-num unsigned-num))
  (:results (res :scs (unsigned-reg)))
  (:result-types unsigned-num)
  (:generator 5
    (inst mov res 64)
    (inst tzcnt res arg)))

;;;; binary conditional VOPs

(define-vop (fast-conditional)
  (:conditional :e)
  (:info)
  (:temporary (:sc unsigned-reg) temp)
  (:policy :fast-safe))

(define-vop (fast-conditional/fixnum fast-conditional)
  (:args (x :scs (any-reg control-stack))
         (y :scs (any-reg control-stack)))
  (:arg-types tagged-num tagged-num)
  (:note "inline fixnum comparison"))

(define-vop (fast-conditional-c/fixnum fast-conditional/fixnum)
  (:args (x :scs (any-reg control-stack)))
  (:arg-types tagged-num (:constant fixnum))
  (:info y))

(define-vop (fast-conditional/signed fast-conditional)
  (:args (x :scs (signed-reg signed-stack))
         (y :scs (signed-reg signed-stack)))
  (:arg-types signed-num signed-num)
  (:note "inline (signed-byte 64) comparison"))

(define-vop (fast-conditional-c/signed fast-conditional/signed)
  (:args (x :scs (signed-reg signed-stack)))
  (:arg-types signed-num (:constant (signed-byte 64)))
  (:info y))

(define-vop (fast-conditional/unsigned fast-conditional)
  (:args (x :scs (unsigned-reg unsigned-stack))
         (y :scs (unsigned-reg unsigned-stack)))
  (:arg-types unsigned-num unsigned-num)
  (:note "inline (unsigned-byte 64) comparison"))

(define-vop (fast-conditional-c/unsigned fast-conditional/unsigned)
  (:args (x :scs (unsigned-reg unsigned-stack)))
  (:arg-types unsigned-num (:constant (unsigned-byte 64)))
  (:info y))

(defun ensure-not-mem+mem (x y temp)
  (cond ((sc-is x immediate)
         (inst mov temp (tn-value x))
         (ensure-not-mem+mem temp y nil))
        (t
         (when (and (tn-p y)
                    (sc-is y immediate))
           (setf y (tn-value y)))
         (when (integerp y)
           (acond ((plausible-signed-imm32-operand-p y)
                   (return-from ensure-not-mem+mem (values x it)))
                  ((typep y '(unsigned-byte 32))
                   ;; Rather than a RIP-relative constant, load a dword (w/o sign-extend)
                   (inst mov :dword temp y)
                   (return-from ensure-not-mem+mem (values x temp))))
           (setq y (ref-shared-qword-literal y)))
         (cond ((or (gpr-tn-p x) (gpr-tn-p y))
                (values x y))
               (t
                (inst mov temp x)
                (values temp y))))))

(defun immediate-operand-smallest-nbits (x)
  (declare (type word x))
  (typecase x
    ((unsigned-byte  8)  8)
    ((unsigned-byte 16) 16)
    ((unsigned-byte 32) 32)
    (t                  64)))

(defun bits->size (bits)
  (ecase bits
    (8  :byte)
    (16 :word)
    (32 :dword)
    (64 :qword)))

;;; Emit the most compact form of the test immediate instruction
;;; by using the smallest operand size that is the large enough to hold
;;; the immediate value Y. The operand size makes little difference since only
;;; flags are affected. However, if the msb (the sign bit) of the immediate
;;; operand at a smaller size is 1 but at its true size (always a :QWORD) is 0,
;;; the S flag value could come out 1 instead of 0.
;;; SIGN-BIT-MATTERS specifies that a shorter operand size must not be selected
;;; if doing so could affect whether the sign flag comes out the same.
;;; e.g. if EDX is #xff, "TEST EDX, #x80" indicates a non-negative result
;;; whereas "TEST DL, #x80" indicates a negative result.
(defun emit-optimized-test-inst (x y temp sign-bit-matters)
  (let* ((bits (if (or (not (integerp y)) (minusp y))
                   64
                   (immediate-operand-smallest-nbits y)))
         (size (unless (eql bits 64)
                 (when (and (logbitp (1- bits) y) sign-bit-matters)
                   (setq bits (* bits 2)))
                 (unless (eql bits 64)
                   (bits->size bits))))
         ;; A size is reducible to byte if there are at most 8 bits set
         ;; in an 8-bit-aligned field. For now I'm only dealing with
         ;; the restricted case of 8 bits at (BYTE 8 8).
         (reducible-to-byte-p
          (and (eq size :word) (not (logtest #xFF y)))))
    (cond  ((and (integerp y)
                 (not (plausible-signed-imm32-operand-p y))
                 (= (logcount (ldb (byte n-word-bits 0) y)) 1))
            (change-vop-flags sb-assem::*current-vop* '(:c))
            (inst bt x (1- (integer-length (ldb (byte n-word-bits 0) y)))))
           ((not size)
            ;; Ensure that both operands are acceptable
            ;; by possibly loading one into TEMP
            (multiple-value-setq (x y) (ensure-not-mem+mem x y temp))
            (inst test :qword x y))
          ((sc-is x control-stack unsigned-stack signed-stack)
           ;; Otherwise, when using an immediate operand smaller
           ;; than 64 bits, narrow the reg/mem operand to match.
           (let ((disp (frame-byte-offset (tn-offset x))))
             (when reducible-to-byte-p
               (setq size :byte disp (1+ disp) y (ash y -8)))
             (inst test size (ea disp rbp-tn) y)))
          (t
           (aver (gpr-tn-p x))
           (if (and reducible-to-byte-p (<= (tn-offset x) rbx-offset))
               ;; Use upper byte of word reg {A,C,D,B}X -> {A,C,D,B}H
               (inst test :byte `(,x . :high-byte) (ash y -8))
               (inst test size x y))))))

(deftransform logtest ((x y) (:or ((signed-word signed-word) *)
                                  ((word word) *))
                       * :vop t)
  t)

(macrolet ((define-logtest-vops ()
             `(progn
                ,@(loop for suffix in '(/fixnum -c/fixnum
                                        /signed -c/signed
                                        /unsigned -c/unsigned)
                        for cost in '(4 3 6 5 6 5)
                        collect
                        `(define-vop (,(symbolicate "FAST-LOGTEST" suffix)
                                      ,(symbolicate "FAST-CONDITIONAL" suffix))
                           (:translate logtest)
                           (:conditional :ne)
                           (:generator ,cost
                             (emit-optimized-test-inst x
                               ,(if (eq suffix '-c/fixnum) `(fixnumize y) 'y)
                               temp nil)))))))
  (define-logtest-vops))

;;; This works for tagged or untagged values, but the vop optimizer
;;; has to pre-adjust Y if tagged.
(define-vop (logtest-memref fast-conditional)
  (:args (x :scs (descriptor-reg)))
  (:arg-types * (:constant integer))
  (:info y)
  (:arg-refs arg-ref)
  (:conditional :ne)
  (:generator 1
   (let ((disp (cdr (tn-ref-memory-access arg-ref))))
     ;; Try as :BYTE, :WORD, :DWORD
     (macrolet ((try (size bits)
                  `(let ((disp disp) (y y) (mask ,(ldb (byte bits 0) -1)))
                     (dotimes (i ,(/ 64 bits))
                       (when (zerop (logandc2 y mask))
                         (inst test ,size (ea disp x) (ash y (* i ,(- bits))))
                         (return-from logtest-memref))
                       (setq mask (ash mask ,bits))
                       (incf disp ,(/ bits 8))))))
       (try :byte   8)
       (try :word  16)
       (try :dword 32))
     (let ((val (ea disp x))
           (y (constantize y)))
       (cond ((integerp y)
              (inst test :qword val y))
             (t
              (inst mov temp val)
              (inst test :qword temp y)))))))

;;; Try to absorb a memory load into LOGTEST.
;;; This removes one instruction and possibly shortens the TEST by eliding
;;; a REX prefix.
(defoptimizer (sb-c::vop-optimize fast-logtest-c/fixnum sb-c::select-representations) (vop)
  (unless (tn-ref-memory-access (vop-args vop))
    (let ((prev (sb-c::previous-vop-is
                 ;; TODO: missing data-vector-ref/simple-vector-c
                 vop '(%raw-instance-ref/signed-word
                       %raw-instance-ref/word
                       instance-index-ref-c
                       ;; This would only happen in unsafe code most likely,
                       ;; because CAR,CDR, etc would need to cast/assert the loaded
                       ;; value to fixnum. However, in practive it doesn't work anyway
                       ;; because there seems to be a spurious MOVE vop in between
                       ;; the SLOT and the FAST-LOGTEST-C/FIXNUM.
                       ;; But ironically enough we _did_ seem to want to optimize
                       ;; an expression in GENERATE-CODE along the lines of:
                       ;;  (if (oddp (length (ir2-component-constants ir2-component))) ...)
                       ;; which, if #+ubsan, would not be admissible
                       ;; because VECTOR-LENGTH is not in a slot.
                       ;; Obviously a GENERATE-CODE bug is the mother of all bugs.
                       #-ubsan slot))))
      (aver (not (vop-results vop))) ; is a :CONDITIONAL vop
      (when (and prev (eq (vop-block prev) (vop-block vop)))
        ;; If the memory ref produces a fixnum, the constant should be a fixnum
        ;; so that we don't see cases such as in lp#1939897.
        ;; In the absence of vop combining, MOVE-TO-WORD would be inserted
        ;; between INSTANCE-INDEX-REF and LOGTEST, but it did not happen yet.
        (let* ((arg (vop-args vop))
               (info-arg (car (vop-codegen-info vop)))
               (constant (if (sc-is (tn-ref-tn arg) any-reg)
                             (fixnumize info-arg)
                             info-arg)))
          (when (and (sc-is (tn-ref-tn arg) any-reg unsigned-reg signed-reg)
                     (eq (tn-ref-tn (vop-results prev)) (tn-ref-tn arg))
                     (sb-c::very-temporary-p (tn-ref-tn arg))
                     (typep constant '(or word signed-word)))
            (binding* ((disp (valid-memref-byte-disp prev) :exit-if-null)
                       (arg-ref (sb-c:reference-tn (tn-ref-tn (vop-args prev)) nil))
                       (new (sb-c::emit-and-insert-vop
                             (sb-c::vop-node vop) (vop-block vop)
                             (template-or-lose 'logtest-memref)
                             arg-ref nil prev (list constant))))
              (setf (tn-ref-memory-access arg-ref) `(:read . ,disp))
              (sb-c::delete-vop prev)
              (sb-c::delete-vop vop)
              new)))))))
(setf (sb-c::vop-info-optimizer (template-or-lose 'fast-logtest-c/signed))
      (cons #'vop-optimize-fast-logtest-c/fixnum-optimizer 'sb-c::select-representations))
(setf (sb-c::vop-info-optimizer (template-or-lose 'fast-logtest-c/unsigned))
      (cons #'vop-optimize-fast-logtest-c/fixnum-optimizer 'sb-c::select-representations))

(deftransform logbitp ((index integer) (:or ((signed-word signed-word) *)
                                            ((word word) *)) * :vop t)
  t)

;;; TODO: The TEST instruction preceding this JEQ is entirely superfluous
;;; and can be removed with a vop optimizer:
;;; E1:       25FE0F0000       AND EAX, 4094
;;; E6:       4885C0           TEST RAX, RAX
;;; E9:       74C9             JEQ L2
(define-vop (logbitp fast-safe-arith-op)
  (:translate logbitp)
  (:conditional :c)
  (:args (bit :scs (signed-reg unsigned-reg))
         ;; CONSTANT here is to allow integers exceeding a fixnum which get NIL
         ;; from IMMEDIATE-CONSTANT-SC. This is only an issue for vops which don't
         ;; take a codegen info for the constant.
         ;; IMMEDIATE is always allowed and pertains to fixnum-sized constants.
         (int :scs (constant immediate signed-reg signed-stack unsigned-reg unsigned-stack)))
  (:arg-refs bit-ref)
  (:arg-types untagged-num untagged-num)
  (:temporary (:sc unsigned-reg
               :unused-if (csubtypep (tn-ref-type bit-ref) (specifier-type '(mod 64))))
              temp)
  (:generator 4
    (when (sc-is int constant immediate)
      (setq int (tn-value int)))
    ;; Force INT to be a RIP-relative operand if it is a constant.
    (let ((word (if (integerp int) (ref-shared-qword-literal int) int)))
      (cond ((eq (tn-kind temp) :unused)) ;; already (mod 64)
            ((if (integerp int)
                 (typep int 'signed-word)
                 (sc-is word signed-reg signed-stack))
             (inst mov temp 63)
             (inst cmp bit temp)

             (inst cmov :na temp bit)
             (setf bit temp))
            (t
             (zeroize temp)
             (inst cmp bit 63)
             (inst cmov :na temp word)
             (setf word temp)))
      (inst bt (if (csubtypep (tn-ref-type bit-ref) (specifier-type '(mod 32)))
                   :dword
                   :qword)
            word bit))))

(define-vop (logbitp/c fast-safe-arith-op)
  (:translate logbitp)
  (:conditional :c)
  (:info bit)
  (:args (int :scs (signed-reg signed-stack unsigned-reg unsigned-stack
                    any-reg control-stack)))
  (:arg-types (:constant (mod 64)) untagged-num)
  (:vop-var vop)
  (:generator 1
    (when (sc-is int any-reg control-stack)
      ;; Acount for fixnum tag bit.
      ;; Reading beyond the sign bit is the same as reading the sign bit.
      (setf bit (min (1- n-word-bits) (+ bit n-fixnum-tag-bits))))
    (cond ((not (gpr-tn-p int))     ; is in memory, issue it as a TEST
           ;; To test bit index 8: add 1 to the disp, and use immediate val 0x01
           ;;             index 9: add 1 to the disp, and use immediate val 0x02
           ;;             etc
           ;; I'm not crazy about this approach, because we lose the connection
           ;; to which TN we're reading.  There needs to be a way to emit the instruction
           ;; as byte-within-stack-tn so that it is understood by other optimizations.
           (binding* ((frame-disp  (frame-byte-offset (tn-offset int)))
                      ((extra-disp bit-shift) (floor bit 8)))
             (inst test :byte (ea (+ frame-disp extra-disp) rbp-tn) (ash 1 bit-shift)))
           (change-vop-flags vop '(:ne))
           (return-from logbitp/c))
          ((= bit 31)       ; test the sign bit of the 32-bit register
           (inst test :dword int int)
           (change-vop-flags vop '(:s))
           (return-from logbitp/c))
          ((= bit 63)
           (inst test int int)
           (change-vop-flags vop '(:s))
           (return-from logbitp/c))
          ((< bit 32)
           (inst test (if (< bit 8) :byte :dword) int (ash 1 bit))
           (change-vop-flags vop '(:ne))
           (return-from logbitp/c)))
    (inst bt (if (<= bit 31) :dword :qword) int bit)))

(define-vop (logbitp-memref fast-conditional)
  (:args (x :scs (descriptor-reg)))
  (:arg-types (:constant (mod 64)) *)
  (:info bit)
  (:arg-refs arg-ref)
  (:vop-var vop)
  (:conditional :ne)
  (:ignore temp)
  (:generator 1
    ;; This resembles the above case for TN being not in a GPR
    (binding* ((slot-disp (cdr (tn-ref-memory-access arg-ref)))
               ((extra-disp bit-shift) (floor bit 8)))
      (inst test :byte (ea (+ slot-disp extra-disp) x) (ash 1 bit-shift)))))

(defoptimizer (sb-c::vop-optimize logbitp/c) (vop)
  (unless (tn-ref-memory-access (vop-args vop))
    (let ((prev (sb-c::previous-vop-is
                 ;; TODO: missing data-vector-ref/simple-vector-c and SLOT
                 vop '(%raw-instance-ref/signed-word
                       %raw-instance-ref/word
                       instance-index-ref-c))))
      (aver (not (vop-results vop))) ; is a :CONDITIONAL vop
      (when (and prev (eq (vop-block prev) (vop-block vop)))
        (let ((arg (vop-args vop)))
          (when (and (eq (tn-ref-tn (vop-results prev)) (tn-ref-tn arg))
                     (sb-c::very-temporary-p (tn-ref-tn arg))
                     (vop-next vop)
                     ;; Ensure we can change the tested flag from CF to ZF
                     (member (vop-name (vop-next vop))
                             '(branch-if compute-from-flags)))
            (binding* ((disp (valid-memref-byte-disp prev) :exit-if-null)
                       (arg-ref
                        (sb-c:reference-tn (tn-ref-tn (vop-args prev)) nil))
                       (bit (car (vop-codegen-info vop)))
                       (info
                        (if (sb-c::previous-vop-is vop 'instance-index-ref-c) ; tagged slot
                            ;; Reading beyond the sign bit is the same as reading the sign bit.
                            (min (+ bit n-fixnum-tag-bits) (1- n-word-bits))
                            bit))
                       (new (sb-c::emit-and-insert-vop
                             (sb-c::vop-node vop) (vop-block vop)
                             (template-or-lose 'logbitp-memref)
                             arg-ref nil prev (list info))))
              (setf (tn-ref-memory-access arg-ref) `(:read . ,disp))
              (change-vop-flags vop '(:ne))
              (sb-c::delete-vop prev)
              (sb-c::delete-vop vop)
              new)))))))

;;; We can delete some MOVEs that seem often to get inserted with iteration constructs
;;; such as (setq i (1+ i)) where the result of 1+ creates a new TN which is moved
;;; to the same TN that is the input to 1+, but PACK chooses different physical registers
;;; for the arg and result of FAST-+-C/FIXNUM=>FIXNUM. So we "cleverly" can use the LEA
;;; instruction as a 3-operand ADD, only to move the destination of LEA back to the
;;; same register that was one of the input operands. Yet the TN which was the result
;;; had otherwise no use. Why does this happen? I don't know.
;;;
;;; So let's try to prevent it by removing the MOVE, which reduces to just the ADD
;;; instruction instead of LEA + MOV. If a vop can only take one physical representation
;;; (such as tagged fixnum) for input, and can only produce that same representation,
;;; and the TN flows back to that vop, then the move is not needed. But if a vop can take
;;; several physical representations, such as accepting either tagged or untagged,
;;; and the SC has not been chosen yet (which happens), then we can't remove.
;;;
;;; For some reason, it seems to come up a trememdous amount with FAST-+-C/FIXNUM=>FIXNUM.
;;; Maybe it comes up with others, I don't know. No harm in trying, I suppose.
;;; To do this for other vops, you have to be certain that the move isn't a coercion.
;;;
;;; [And it would be nice if every backend named their vops consistently
;;; so that this optimizer could be made architecture-independent]
;;; The SB-C::DELETE- function isn't defined yet in the build order, so wrap it in a lambda.
(flet ((optimizer (vop) (sb-c::delete-unnecessary-move vop)))
  (dolist (name '(sb-vm::fast-+-c/fixnum=>fixnum
                  sb-vm::fast-+-c/signed=>signed
                  sb-vm::fast-+-c/unsigned=>unsigned
                  sb-vm::fast---c/fixnum=>fixnum
                  sb-vm::fast---c/signed=>signed
                  sb-vm::fast---c/unsigned=>unsigned
                  sb-vm::fast-*-c/fixnum=>fixnum
                  sb-vm::fast-*-c/signed=>signed
                  sb-vm::fast-*-c/unsigned=>unsigned))
    (sb-c::set-vop-optimizer (template-or-lose name) #'optimizer)))

(defun emit-optimized-cmp (x y temp &optional x-ctype)
  ;; Shorten the encoding by eliding a REX prefix where the upper bits
  ;; can not possibly matter.
  ;; Be sure to account for N-FIXNUM-TAG-BITS in determining how many bits
  ;; of precision are in the representation of X.
  ;; Little-endian addressing makes this valid for stack TNs as well as registers.
  (let ((operand-size (if (and (numeric-type-p x-ctype)
                               (typep y '(signed-byte 32))
                               (csubtypep x-ctype
                                          (if (sc-is x any-reg descriptor-reg control-stack)
                                              (specifier-type '(signed-byte 31))
                                              (specifier-type '(signed-byte 32)))))
                          :dword
                          :qword)))
    (if (and (gpr-tn-p x) (eql y 0))
      ;; Amazingly (to me), use of TEST in lieu of CMP produces all the correct
      ;; flag bits for inequality comparison as well as EQL comparison.
      ;; You'd think that the Jxx instruction should examine _only_ the S flag,
      ;; but in fact the other flags are right too. Nonetheless this is
      ;; quite confusing, and I would prefer that we alter the branch test
      ;; when emitting TEST in place of CMP.
        (inst test operand-size x x) ; smaller instruction
        (progn (multiple-value-setq (x y) (ensure-not-mem+mem x y temp))
               (inst cmp operand-size x y)))))


(macrolet ((define-conditional-vop (tran cond unsigned
                                    addend addend-signed addend-unsigned
                                    &optional zero)
             `(progn
                ,@(loop for (suffix cost signed constant)
                        in '((/fixnum 4 t)
                             (-c/fixnum 3 t t)
                             (/signed 6 t)
                             (-c/signed 5 t t)
                             (/unsigned 6)
                              (-c/unsigned 5 nil t))
                        collect
                        (flet ((fix (n)
                                 (if (eq suffix '-c/fixnum)
                                     `(fixnumize ,n)
                                     n)))
                          `(define-vop (,(symbolicate "FAST-IF-" tran suffix)
                                        ,(symbolicate "FAST-CONDITIONAL"  suffix))
                             (:translate ,tran)
                             (:vop-var vop)
                             (:conditional)
                             (:conditional ,(if signed cond unsigned))
                             (:arg-refs x-tn-ref)
                             (:generator ,cost
                               ,(when constant
                                  `(cond ((zerop (+ y ,addend))
                                          (setf y 0)
                                          (change-vop-flags
                                           vop
                                           ',(if signed
                                                 (list addend-signed)
                                                 (list addend-unsigned))))
                                         ,@(when (and zero
                                                      signed)
                                             ;; (< x 0) can be tested using only the sign flag,
                                             ;; which allows sub x, y; test x, x to be optimized
                                             `(((zerop y)
                                                (change-vop-flags vop '(,zero)))))
                                         ((and
                                           (not (plausible-signed-imm32-operand-p ,(fix 'y)))
                                           (plausible-signed-imm32-operand-p ,(fix `(+ y ,addend))))
                                          (incf y ,addend)
                                          (change-vop-flags
                                           vop
                                           ',(if signed
                                                 (list addend-signed)
                                                 (list addend-unsigned))))))
                               (emit-optimized-cmp
                                 x ,(fix 'y)
                                 temp (tn-ref-type x-tn-ref)))))))))
  (define-conditional-vop < :l :b -1 :le :be :s)
  (define-conditional-vop > :g :a 1 :ge :ae))

(define-vop (<-unsigned-signed)
  (:translate <)
  (:args (unsigned :scs (unsigned-reg))
         (signed :scs (signed-reg)))
  (:arg-types unsigned-num signed-num)
  (:temporary (:sc signed-reg) temp)
  (:conditional :b)
  (:policy :fast-safe)
  (:generator 7
    (zeroize temp)
    (inst test signed signed)
    (inst cmov :ge temp signed)
    (inst cmp unsigned temp)))

(define-vop (>-unsigned-signed)
  (:translate >)
  (:args (unsigned :scs (unsigned-reg))
         (signed :scs (signed-reg)))
  (:arg-types unsigned-num signed-num)
  (:policy :fast-safe)
  (:conditional :a)
  (:generator 7
    (inst test signed signed)
    (inst jmp :l done)
    (inst cmp unsigned signed)
    done))

(define-vop (<-signed-unsigned)
  (:translate <)
  (:args (signed :scs (signed-reg))
         (unsigned :scs (unsigned-reg)))
  (:arg-types signed-num unsigned-num)
  (:conditional :a)
  (:policy :fast-safe)
  (:generator 7
    (inst test signed signed)
    (inst jmp :l done)
    (inst cmp unsigned signed)
    done))

(define-vop (>-signed-unsigned <-signed-unsigned)
  (:translate >)
  (:temporary (:sc signed-reg) temp)
  (:conditional :a)
  (:generator 7
    (zeroize temp)
    (inst test signed signed)
    (inst cmov :ge temp signed)
    (inst cmp temp unsigned)))

(define-vop (eql-unsigned-signed)
  (:translate eql)
  (:args (unsigned :scs (unsigned-reg))
         (signed :scs (signed-reg)))
  (:arg-types unsigned-num signed-num)
  (:conditional :e)
  (:policy :fast-safe)
  (:generator 7
    (inst test signed signed)
    (inst jmp :l done)
    (inst cmp unsigned signed)
    done))

(define-vop (eql-signed-unsigned eql-unsigned-signed)
  (:args (signed :scs (signed-reg))
         (unsigned :scs (unsigned-reg)))
  (:arg-types signed-num unsigned-num))

(define-vop (fast-if-eql/signed fast-conditional/signed)
  (:translate eql)
  (:generator 6 (emit-optimized-cmp x y temp)))

(define-vop (fast-if-eql-c/signed fast-conditional-c/signed)
  (:translate eql)
  (:generator 5 (emit-optimized-cmp x y temp)))

(define-vop (fast-if-eql/unsigned fast-conditional/unsigned)
  (:translate eql)
  (:generator 6 (emit-optimized-cmp x y temp)))

(define-vop (fast-if-eql-c/unsigned fast-conditional-c/unsigned)
  (:translate eql)
  (:generator 5 (emit-optimized-cmp x y temp)))

;;;; 64-bit logical operations

;;; Only the lower 6 bits of the shift amount are significant.
(macrolet ((define (translate operation)
             `(define-vop ()
                (:translate ,translate)
                (:note ,(string translate))
                (:policy :fast-safe)
                (:args (num :scs (unsigned-reg) :target r)
                       (amount :scs (signed-reg) :target rcx))
                (:arg-types unsigned-num tagged-num)
                (:temporary (:sc signed-reg :offset rcx-offset :from (:argument 1)) rcx)
                (:results (r :scs (unsigned-reg) :from (:argument 0)))
                (:result-types unsigned-num)
                (:generator 1
                 (move r num)
                 (move rcx amount :dword)
                 (inst ,operation r :cl)))))
  (define shift-towards-start shr)
  (define shift-towards-end   shl))

;;;; Modular functions

(defmacro define-mod-binop ((name prototype) function)
  (if (search "FAST-*" (string prototype)) ; fast-* doesn't accept stack locations yet
      `(define-vop (,name ,prototype)
           (:args (x :target r :scs (unsigned-reg signed-reg)
                     :load-if (not (and (or (sc-is x unsigned-stack)
                                            (sc-is x signed-stack))
                                        (or (sc-is y unsigned-reg)
                                            (sc-is y signed-reg))
                                        (or (sc-is r unsigned-stack)
                                            (sc-is r signed-stack))
                                        (location= x r))))
                  (y :scs (unsigned-reg signed-reg unsigned-stack signed-stack)))
         (:arg-types untagged-num untagged-num)
         (:results (r :scs (unsigned-reg signed-reg) :from (:argument 0)
                      :load-if (not (and (or (sc-is x unsigned-stack)
                                             (sc-is x signed-stack))
                                         (or (sc-is y unsigned-reg)
                                             (sc-is y unsigned-reg))
                                         (or (sc-is r unsigned-stack)
                                             (sc-is r unsigned-stack))
                                         (location= x r)))))
         (:result-types unsigned-num)
         (:translate ,function))
      `(define-vop (,name ,prototype)
         (:args (x :scs (unsigned-reg signed-reg unsigned-stack signed-stack immediate)
                   :load-if nil :target r)
                (y :scs (unsigned-reg signed-reg unsigned-stack signed-stack immediate)
                   :load-if nil))
         (:arg-types untagged-num untagged-num)
         (:results (r :scs (unsigned-reg signed-reg unsigned-stack signed-stack)
                      :load-if nil))
         (:result-types unsigned-num)
         (:translate ,function))))

(defmacro define-mod-binop-c ((name prototype) function)
  (if (search "FAST-*" (string prototype)) ; fast-* doesn't accept stack locations yet
      `(define-vop (,name ,prototype)
         (:args (x :target r :scs (unsigned-reg signed-reg) :load-if t))
         (:info y)
         (:arg-types untagged-num (:constant (or (unsigned-byte 64) (signed-byte 64))))
         (:results (r :scs (unsigned-reg signed-reg) :from (:argument 0) :load-if t))
         (:result-types unsigned-num)
         (:translate ,function))
      `(define-vop (,name ,prototype)
         (:args (x :target r :scs (unsigned-reg signed-reg unsigned-stack signed-stack)))
         (:info y)
         (:arg-types untagged-num (:constant (or (unsigned-byte 64) (signed-byte 64))))
         (:results (r :scs (unsigned-reg signed-reg unsigned-stack signed-stack) :load-if nil))
         (:result-types unsigned-num)
         (:translate ,function))))

(macrolet ((def (name)
             (let ((fun64   (symbolicate name "-MOD64"))
                   (funfx   (symbolicate name "-MODFX"))
                   (vopu    (symbolicate "FAST-" name "/UNSIGNED=>UNSIGNED"))
                   (vopcu   (symbolicate "FAST-" name "-C/UNSIGNED=>UNSIGNED"))
                   (vopf    (symbolicate "FAST-" name "/FIXNUM=>FIXNUM"))
                   (vopcf   (symbolicate "FAST-" name "-C/FIXNUM=>FIXNUM"))
                   (vop64u  (symbolicate "FAST-" name "-MOD64/WORD=>UNSIGNED"))
                   (vop64f  (symbolicate "FAST-" name "-MOD64/FIXNUM=>FIXNUM"))
                   (vop64cu (symbolicate "FAST-" name "-MOD64-C/WORD=>UNSIGNED"))
                   (vop64cf (symbolicate "FAST-" name "-MOD64-C/FIXNUM=>FIXNUM"))
                   (vopfxf  (symbolicate "FAST-" name "-MODFX/FIXNUM=>FIXNUM"))
                   (vopfxcf (symbolicate "FAST-" name "-MODFX-C/FIXNUM=>FIXNUM")))
               (declare (ignore vop64cf)) ; maybe someone will want it some day
               `(progn
                  (define-modular-fun ,fun64 (x y) ,name :untagged nil 64)
                  (define-modular-fun ,funfx (x y) ,name :tagged t #.n-fixnum-bits)
                  (define-mod-binop (,vop64u ,vopu) ,fun64)
                  ;; This seems a bit lame. Could we not just have one vop
                  ;; which which takes any combination of signed/unsigned reg
                  ;; and which translates the normal function and the modular function?
                  (define-vop (,vop64f ,vopf) (:translate ,fun64))
                  (define-vop (,vopfxf ,vopf) (:translate ,funfx))
                  (define-mod-binop-c (,vop64cu ,vopcu) ,fun64)
                  (define-vop (,vopfxcf ,vopcf) (:translate ,funfx))))))
  (def +)
  (def -)
  (def *))

(define-modular-fun %negate-mod64 (x) %negate :untagged nil 64)
(define-vop (%negate-mod64)
  (:translate %negate-mod64)
  (:policy :fast-safe)
  (:args (x :scs (unsigned-reg) :target r))
  (:arg-types unsigned-num)
  (:results (r :scs (unsigned-reg)))
  (:result-types unsigned-num)
  (:generator 3
    (move r x)
    (inst neg r)))

(define-modular-fun %negate-modfx (x) %negate :tagged t #.n-fixnum-bits)
(define-vop (%negate-modfx fast-negate/fixnum)
  (:translate %negate-modfx))
(in-package "SB-C")

(defknown sb-vm::%lea-mod64 (integer integer (member 1 2 4 8) (signed-byte 64))
  (unsigned-byte 64)
  (foldable flushable movable))
(defknown sb-vm::%lea-modfx (integer integer (member 1 2 4 8) (signed-byte 64))
  fixnum
  (foldable flushable movable))

(define-modular-fun-optimizer %lea ((base index scale disp) :untagged nil :width width)
  (when (and (<= width 64)
             (constant-lvar-p scale)
             (constant-lvar-p disp))
    (cut-to-width base :untagged width nil)
    (cut-to-width index :untagged width nil)
    'sb-vm::%lea-mod64))
(define-modular-fun-optimizer %lea ((base index scale disp) :tagged t :width width)
  (when (and (<= width sb-vm:n-fixnum-bits)
             (constant-lvar-p scale)
             (constant-lvar-p disp))
    (cut-to-width base :tagged width t)
    (cut-to-width index :tagged width t)
    'sb-vm::%lea-modfx))

#+sb-xc-host
(progn
  (defun sb-vm::%lea-mod64 (base index scale disp)
    (ldb (byte 64 0) (%lea base index scale disp)))
  (defun sb-vm::%lea-modfx (base index scale disp)
    (mask-signed-field sb-vm:n-fixnum-bits
                       (%lea base index scale disp))))
#-sb-xc-host
(progn
  (defun sb-vm::%lea-mod64 (base index scale disp)
    (let ((base (logand base #xffffffffffffffff))
          (index (logand index #xffffffffffffffff)))
      ;; can't use modular version of %LEA, as we only have VOPs for
      ;; constant SCALE and DISP.
      (ldb (byte 64 0) (+ base (* index scale) disp))))
  (defun sb-vm::%lea-modfx (base index scale disp)
    (let* ((fixnum-width sb-vm:n-fixnum-bits)
           (base (mask-signed-field fixnum-width base))
           (index (mask-signed-field fixnum-width index)))
      ;; can't use modular version of %LEA, as we only have VOPs for
      ;; constant SCALE and DISP.
      (mask-signed-field fixnum-width (+ base (* index scale) disp)))))

(in-package "SB-VM")

(define-vop (%lea-mod64/unsigned=>unsigned
             %lea/unsigned=>unsigned)
  (:translate %lea-mod64))
(define-vop (%lea-modfx/fixnum=>fixnum
             %lea/fixnum=>fixnum)
  (:translate %lea-modfx))

;;; logical operations
(define-modular-fun lognot-mod64 (x) lognot :untagged nil 64)
(define-vop (lognot-mod64/unsigned=>unsigned)
  (:translate lognot-mod64)
  (:args (x :scs (unsigned-reg unsigned-stack) :target r
            :load-if (not (and (sc-is x unsigned-stack)
                               (sc-is r unsigned-stack)
                               (location= x r)))))
  (:arg-types unsigned-num)
  (:results (r :scs (unsigned-reg)
               :load-if (not (and (sc-is x unsigned-stack)
                                  (sc-is r unsigned-stack)
                                  (location= x r)))))
  (:result-types unsigned-num)
  (:policy :fast-safe)
  (:generator 1
    (move r x)
    (inst not r)))

(define-source-transform logeqv (&rest args)
  (if (oddp (length args))
      `(logxor ,@args)
      `(lognot (logxor ,@args))))
(define-source-transform logandc2 (x y)
  `(logand ,x (lognot ,y)))
(define-source-transform logorc1 (x y)
  `(logior (lognot ,x) ,y))
(define-source-transform logorc2 (x y)
  `(logior ,x (lognot ,y)))
(define-source-transform lognor (x y)
  `(lognot (logior ,x ,y)))
(define-source-transform lognand (x y)
  `(lognot (logand ,x ,y)))

;;;; bignum stuff

(define-vop (bignum-length get-header-data)
  (:translate sb-bignum:%bignum-length)
  (:policy :fast-safe)
  (:results (res :scs (unsigned-reg)))
  (:generator 6
    #.(assert (subtypep 'sb-bignum:bignum-length '(unsigned-byte 32)))
    (inst mov :dword res (ea (1+ (- other-pointer-lowtag)) x))))

(define-vop (bignum-set-length set-header-data)
  (:translate sb-bignum:%bignum-set-length)
  (:policy :fast-safe))

#-bignum-assertions ; %BIGNUM-ref is an inline function if compiling with assertions
(define-full-reffer bignum-ref * bignum-digits-offset other-pointer-lowtag
  (unsigned-reg) unsigned-num sb-bignum:%bignum-ref)
#-bignum-assertions ; does not get called if compiling with assertions
(define-full-reffer+addend bignum-ref-with-offset * bignum-digits-offset
  other-pointer-lowtag (unsigned-reg) unsigned-num
  sb-bignum:%bignum-ref-with-offset)
(define-full-setter bignum-set * bignum-digits-offset other-pointer-lowtag
  (unsigned-reg) unsigned-num
  #+bignum-assertions sb-bignum:%%bignum-set
  #-bignum-assertions sb-bignum:%bignum-set)

(define-vop (digit-0-or-plus)
  (:translate sb-bignum:%digit-0-or-plusp)
  (:policy :fast-safe)
  (:args (digit :scs (unsigned-reg)))
  (:arg-types unsigned-num)
  (:conditional :ns)
  (:generator 3
    (inst test digit digit)))


;;; For add and sub with carry, the sc of carry argument is unsigned-reg
;;; or any-reg so that it may be passed either as tagged or untagged.
;;; This is easy to deal with and may save a fixnum-word conversion.
(define-vop (add-w/carry)
  (:translate sb-bignum:%add-with-carry)
  (:policy :fast-safe)
  (:args (a :scs (unsigned-reg) :target result)
         (b :scs (unsigned-reg unsigned-stack) :to :eval)
         (c :scs (any-reg unsigned-reg control-stack immediate) :target temp))
  (:arg-types unsigned-num unsigned-num positive-fixnum)
  (:temporary (:sc any-reg :from (:argument 2) :to :eval) temp)
  (:results (result :scs (unsigned-reg) :from (:argument 0))
            (carry :scs (unsigned-reg)))
  (:optional-results carry)
  (:result-types unsigned-num positive-fixnum)
  (:generator 4
    (move result a)
    (cond ((and (sc-is c immediate)
                (zerop (tn-value c)))
           (inst add result b))
          (t
           (move temp c)
           (inst neg temp)  ; Set the carry flag to 0 if c=0 else to 1
           (inst adc result b)))

    (unless (eq (tn-kind carry) :unused)
     (inst set :c carry)
     (inst and :dword carry 1))))

;;; Note: the borrow is 1 for no borrow and 0 for a borrow, the opposite
;;; of the x86-64 convention.
(define-vop (sub-w/borrow)
  (:translate sb-bignum:%subtract-with-borrow)
  (:policy :fast-safe)
  (:args (a :scs (unsigned-reg) :to :eval :target result)
         (b :scs (unsigned-reg unsigned-stack) :to :result)
         (c :scs (any-reg unsigned-reg control-stack immediate)))
  (:arg-types unsigned-num unsigned-num positive-fixnum)
  (:results (result :scs (unsigned-reg) :from :eval)
            (borrow :scs (unsigned-reg)))
  (:optional-results borrow)
  (:result-types unsigned-num positive-fixnum)
  (:generator 5
    (cond ((and (sc-is c immediate)
                (eql (tn-value c) 1))
           (move result a)
           (inst sub result b))
          (t
           (inst cmp c 1)   ; Set the carry flag to 1 if c=0 else to 0
           (move result a)
           (inst sbb result b)))
    (unless (eq (tn-kind borrow) :unused)
      (inst mov borrow 1)
      (inst sbb :dword borrow 0))))

(define-vop (bignum-add-loop)
  (:args (a :scs (descriptor-reg) :to :save)
         (b :scs (descriptor-reg) :to :save)
         (la :scs (unsigned-reg) :target remaining-length)
         (lb :scs (unsigned-reg) :target length)
         (r :scs (descriptor-reg)))
  (:arg-types bignum bignum unsigned-num bignum unsigned-num)
  (:temporary (:sc unsigned-reg :from (:argument 2)) length)
  (:temporary (:sc unsigned-reg :from (:argument 3)) remaining-length)
  (:temporary (:sc unsigned-reg) n index sign-digit-a sign-digit-b)
  (:generator 10
    (move remaining-length la :dword)
    (move length lb :dword)
    (inst mov sign-digit-a (ea (- #1=(- (* bignum-digits-offset n-word-bytes) other-pointer-lowtag) 8) a la 8))
    (inst mov sign-digit-b (ea (- #1# 8) b lb 8))
    (inst sar sign-digit-a 63)
    (inst sar sign-digit-b 63)

    (inst sub :dword remaining-length length)
    (inst inc :dword remaining-length)

    (zeroize index) ;; clears CF as well

    LOOP-B
    (inst mov n (ea #1# b index 8))
    (inst adc n (ea #1# a index 8))
    (inst mov (ea #1# r index 8) n)
    (inst inc :dword index)
    (inst dec :dword length)
    (inst jmp :nz LOOP-B)

    ;; Add the sign digit with carry to the remaining digits of the longest bignum
    (move length remaining-length :dword) ;; remaining length + 1
    (inst dec :dword length)
    (inst jmp :z DONE)

    LOOP-A
    (inst mov n (ea #1# a index 8))
    (inst adc n sign-digit-b)
    (inst mov (ea #1# r index 8) n)

    (inst inc :dword index)
    (inst dec :dword length)

    (inst jmp :nz LOOP-A)

    DONE
    (inst adc sign-digit-a sign-digit-b)
    (inst mov (ea #1# r index 8) sign-digit-a)))

(define-vop (bignum-add-word-loop)
  (:args (a :scs (descriptor-reg) :to :save)
         (b :scs (unsigned-reg) :target n)
         (la :scs (unsigned-reg) :target length)
         (r :scs (descriptor-reg)))
  (:arg-types bignum unsigned-num unsigned-num bignum)
  (:temporary (:sc unsigned-reg :from (:argument 1)) n)
  (:temporary (:sc unsigned-reg :from (:argument 2)) length)
  (:temporary (:sc unsigned-reg) index sign-digit-a sign-digit-b)
  (:generator 10
    (inst mov sign-digit-a (ea (- #1=(- (* bignum-digits-offset n-word-bytes) other-pointer-lowtag) 8) a la 8))
    (inst mov sign-digit-b n)
    (inst sar sign-digit-a 63)
    (inst sar sign-digit-b 63)
    (move n b)
    (move length la :dword)

    (inst add n (ea #1# a))
    (inst mov (ea #1# r) n)
    (inst mov :dword index 1)
    (inst dec :dword length)
    (inst jmp :z DONE)

    LOOP-A
    (inst mov n (ea #1# a index 8))
    (inst adc n sign-digit-b)
    (inst mov (ea #1# r index 8) n)

    (inst inc :dword index)
    (inst dec :dword length)

    (inst jmp :nz LOOP-A)

    DONE
    (inst adc sign-digit-a sign-digit-b)
    (inst mov (ea #1# r index 8) sign-digit-a)))

(define-vop (bignum-sub-word-loop)
  (:args (a :scs (descriptor-reg))
         (b :scs (unsigned-reg))
         (la :scs (unsigned-reg))
         (r :scs (descriptor-reg)))
  (:arg-types bignum unsigned-num unsigned-num bignum)
  (:temporary (:sc unsigned-reg) length)
  (:temporary (:sc unsigned-reg) index sign-digit-a sign-digit-b
              digit-a)
  (:generator 10
    ;; Compute the signs first to not affect CF later
    (inst mov sign-digit-a (ea (- #1=(- (* bignum-digits-offset n-word-bytes) other-pointer-lowtag) 8) a la 8))
    (inst mov sign-digit-b b)
    (inst sar sign-digit-a 63)
    (inst sar sign-digit-b 63)

    (inst mov digit-a (ea #1# a))
    (inst sub digit-a b)
    (inst mov (ea #1# r) digit-a)
    (inst mov index 1)

    (move length la)
    (inst dec length)
    (inst jmp :z DONE)

    LOOP
    (inst mov digit-a (ea #1# a index 8))
    (inst sbb digit-a sign-digit-b)
    (inst mov (ea #1# r index 8) digit-a)

    (inst inc index)
    (inst dec length)
    (inst jmp :nz LOOP)

    DONE
    (inst sbb sign-digit-a sign-digit-b)
    (inst mov (ea #1# r index 8) sign-digit-a)))

(define-vop (word-sub-bignum-loop)
  (:args (a :scs (unsigned-reg))
         (b :scs (descriptor-reg))
         (lb :scs (unsigned-reg))
         (r :scs (descriptor-reg)))
  (:arg-types unsigned-num bignum unsigned-num bignum)
  (:temporary (:sc unsigned-reg) length)
  (:temporary (:sc unsigned-reg) n index sign-digit-a sign-digit-b)
  (:generator 10
    (move n a)
    ;; Compute the signs first to not affect CF later
    (inst mov sign-digit-b (ea (- #1=(- (* bignum-digits-offset n-word-bytes) other-pointer-lowtag) 8) b lb 8))
    (inst mov sign-digit-a a)
    (inst sar sign-digit-a 63)
    (inst sar sign-digit-b 63)

    (inst sub n (ea #1# b))
    (inst mov (ea #1# r) n)
    (inst mov index 1)

    (move length lb)
    (inst dec length)
    (inst jmp :z DONE)

    LOOP
    (move n sign-digit-a)
    (inst sbb n (ea #1# b index 8))
    (inst mov (ea #1# r index 8) n)

    (inst inc index)
    (inst dec length)
    (inst jmp :nz LOOP)

    DONE
    (inst sbb sign-digit-a sign-digit-b)
    (inst mov (ea #1# r index 8) sign-digit-a)))

(define-vop (bignum-negate-loop)
  (:args (a :scs (descriptor-reg) :to :save)
         (l :scs (unsigned-reg) :target length)
         (r :scs (descriptor-reg) :to :save))
  (:arg-types bignum unsigned-num bignum)
  (:temporary (:sc unsigned-reg :from (:argument 1)) length)
  (:temporary (:sc unsigned-reg) index)
  (:results (last1 :scs (unsigned-reg))
            (last2 :scs (unsigned-reg)))
  (:result-types unsigned-num unsigned-num)
  (:generator 10
    (zeroize last2)
    (zeroize index)
    (move length l :dword)
    LOOP
    (move last1 last2)
    (inst mov last2 0)
    (inst sbb last2 (ea #1=(- (* bignum-digits-offset n-word-bytes) other-pointer-lowtag) a index 8))
    (inst mov (ea #1# r index 8) last2)
    (inst inc :dword index)
    (inst dec :dword length)
    (inst jmp :nz LOOP)))

(define-vop (bignum-negate-in-place-loop)
  (:args (a :scs (descriptor-reg) :to :save)
         (l :scs (unsigned-reg) :target length))
  (:arg-types bignum unsigned-num)
  (:temporary (:sc unsigned-reg :from (:argument 1)) length)
  (:temporary (:sc unsigned-reg) index temp)
  (:generator 10
    (zeroize index)
    (move length l :dword)
    LOOP
    (inst mov temp 0)
    (inst sbb temp #1=(ea (- (* bignum-digits-offset n-word-bytes) other-pointer-lowtag) a index 8))
    (inst mov #1# temp)
    (inst inc :dword index)
    (inst dec :dword length)
    (inst jmp :nz LOOP)))

(define-vop (bignum-negate-last-two-loop)
  (:args (a :scs (descriptor-reg) :to :save)
         (l :scs (unsigned-reg) :target length))
  (:arg-types bignum unsigned-num)
  (:temporary (:sc unsigned-reg :from (:argument 1)) length)
  (:temporary (:sc unsigned-reg) index)
  (:results (last1 :scs (unsigned-reg))
            (last2 :scs (unsigned-reg)))
  (:result-types unsigned-num unsigned-num)
  (:generator 10
    (zeroize last2)
    (zeroize index)
    (move length l :dword)
    LOOP
    (move last1 last2)
    (inst mov last2 0)
    (inst sbb last2 (ea (- (* bignum-digits-offset n-word-bytes) other-pointer-lowtag) a index 8))
    (inst inc :dword index)
    (inst dec :dword length)
    (inst jmp :nz LOOP)))

(define-vop (bignum-mulx-and-add-word-loop)
  (:args (a :scs (descriptor-reg))
         (b :scs (unsigned-reg) :target rdx)
         (la :scs (unsigned-reg) :target length)
         (r :scs (descriptor-reg)))
  (:arg-types bignum unsigned-num unsigned-num bignum)
  (:temporary (:sc unsigned-reg) length)
  (:temporary (:sc unsigned-reg) index lo hi prev-hi)
  (:temporary (:sc unsigned-reg :offset rdx-offset) rdx)
  (:generator 10

    (move length la)
    (move rdx b)
    (zeroize prev-hi)
    (zeroize index) ;; clears CF

    LOOP
    (inst mulx hi lo (ea #1=(- (* bignum-digits-offset n-word-bytes) other-pointer-lowtag) a index 8))
    (inst adc lo prev-hi)
    (move prev-hi hi)
    (inst mov (ea #1# r index 8) lo)

    (inst inc :dword index)
    (inst dec :dword length)
    (inst jmp :nz LOOP)

    (inst adc hi 0)
    (inst mov (ea #1# r index 8) hi)))

(define-vop (bignum-mult-and-add-3-arg)
  (:translate sb-bignum:%multiply-and-add)
  (:policy :fast-safe)
  (:args (x :scs (unsigned-reg) :target eax)
         (y :scs (unsigned-reg unsigned-stack))
         (carry-in :scs (unsigned-reg unsigned-stack)))
  (:arg-types unsigned-num unsigned-num unsigned-num)
  (:temporary (:sc unsigned-reg :offset rax-offset :from (:argument 0)
                   :to (:result 1) :target lo) eax)
  (:temporary (:sc unsigned-reg :offset rdx-offset :from (:argument 1)
                   :to (:result 0) :target hi) edx)
  (:results (hi :scs (unsigned-reg))
            (lo :scs (unsigned-reg)))
  (:result-types unsigned-num unsigned-num)
  (:generator 20
    (move eax x)
    (inst mul y)
    (inst add eax carry-in)
    (inst adc edx 0)
    (move hi edx)
    (move lo eax)))

(define-vop (bignum-mult-and-add-4-arg)
  (:translate sb-bignum:%multiply-and-add)
  (:policy :fast-safe)
  (:args (x :scs (unsigned-reg) :target eax)
         (y :scs (unsigned-reg unsigned-stack))
         (prev :scs (unsigned-reg unsigned-stack))
         (carry-in :scs (unsigned-reg unsigned-stack)))
  (:arg-types unsigned-num unsigned-num unsigned-num unsigned-num)
  (:temporary (:sc unsigned-reg :offset rax-offset :from (:argument 0)
                   :to (:result 1) :target lo) eax)
  (:temporary (:sc unsigned-reg :offset rdx-offset :from (:argument 1)
                   :to (:result 0) :target hi) edx)
  (:results (hi :scs (unsigned-reg))
            (lo :scs (unsigned-reg)))
  (:result-types unsigned-num unsigned-num)
  (:generator 20
    (move eax x)
    (inst mul y)
    (inst add eax prev)
    (inst adc edx 0)
    (inst add eax carry-in)
    (inst adc edx 0)
    (move hi edx)
    (move lo eax)))

(define-vop (bignum-mult)
  (:translate sb-bignum:%multiply)
  (:policy :fast-safe)
  (:args (x :scs (unsigned-reg) :target eax)
         (y :scs (unsigned-reg unsigned-stack)))
  (:arg-types unsigned-num unsigned-num)
  (:temporary (:sc unsigned-reg :offset rax-offset :from (:argument 0)
                   :to (:result 1) :target lo) eax)
  (:temporary (:sc unsigned-reg :offset rdx-offset :from (:argument 1)
                   :to (:result 0) :target hi) edx)
  (:results (hi :scs (unsigned-reg))
            (lo :scs (unsigned-reg)))
  (:result-types unsigned-num unsigned-num)
  (:generator 20
    (move eax x)
    (inst mul y)
    (move hi edx)
    (move lo eax)))

(define-vop (mulhi)
  (:translate %multiply-high)
  (:policy :fast-safe)
  (:args (x :scs (unsigned-reg) :target eax)
         (y :scs (unsigned-reg unsigned-stack)))
  (:arg-types unsigned-num unsigned-num)
  (:temporary (:sc unsigned-reg :offset rax-offset :from (:argument 0))
              eax)
  (:temporary (:sc unsigned-reg :offset rdx-offset :from (:argument 1)
                   :to (:result 0) :target hi) edx)
  (:results (hi :scs (unsigned-reg)))
  (:result-types unsigned-num)
  (:generator 20
    (move eax x)
    (inst mul y)
    (move hi edx)))

(define-vop (mulhi/fx)
  (:translate %multiply-high)
  (:policy :fast-safe)
  (:args (x :scs (any-reg) :target eax)
         (y :scs (unsigned-reg unsigned-stack)))
  (:arg-types positive-fixnum unsigned-num)
  (:temporary (:sc any-reg :offset rax-offset :from (:argument 0)) eax)
  (:temporary (:sc any-reg :offset rdx-offset :from (:argument 1)
                   :to (:result 0) :target hi) edx)
  (:results (hi :scs (any-reg)))
  (:result-types positive-fixnum)
  (:generator 15
    (move eax x)
    (inst mul y)
    (move hi edx)
    (inst and hi (lognot fixnum-tag-mask))))

(define-vop ()
  (:translate %signed-multiply-high)
  (:policy :fast-safe)
  (:args (x :scs (signed-reg) :target eax)
         (y :scs (signed-reg signed-stack)))
  (:arg-types signed-num signed-num)
  (:temporary (:sc signed-reg :offset rax-offset :from (:argument 0))
              eax)
  (:temporary (:sc signed-reg :offset rdx-offset :from (:argument 1)
                   :to (:result 0) :target hi) edx)
  (:results (hi :scs (signed-reg)))
  (:result-types signed-num)
  (:generator 20
    (move eax x)
    (inst imul y)
    (move hi edx)))

(define-vop (signed-multiply-low-high)
  (:policy :fast-safe)
  (:args (x :scs (any-reg) :target eax)
         (y :scs (any-reg)))
  (:arg-types tagged-num tagged-num)
  (:temporary (:sc any-reg :offset rax-offset :from (:argument 0)
               :to (:result 1) :target lo) eax)
  (:temporary (:sc any-reg :offset rdx-offset :from (:argument 1)
               :to (:result 0) :target hi) edx)
  (:results (lo :scs (unsigned-reg))
            (hi :scs (signed-reg)))
  (:result-types unsigned-num signed-num)
  (:generator 20
    (move eax x)
    (inst imul y)
    (move hi edx)
    (move lo eax)))

(define-vop (bignum-floor)
  (:translate sb-bignum:%bigfloor)
  (:policy :fast-safe)
  (:args (div-high :scs (unsigned-reg) :target edx)
         (div-low :scs (unsigned-reg) :target eax)
         (divisor :scs (unsigned-reg unsigned-stack)))
  (:arg-types unsigned-num unsigned-num unsigned-num)
  (:temporary (:sc unsigned-reg :offset rax-offset :from (:argument 1)
               :to (:result 0) :target quo) eax)
  (:temporary (:sc unsigned-reg :offset rdx-offset :from (:argument 0)
               :to (:result 1) :target rem) edx)
  (:results (quo :scs (unsigned-reg))
            (rem :scs (unsigned-reg)))
  (:result-types unsigned-num unsigned-num)
  (:generator 300
    (move edx div-high)
    (move eax div-low)
    (inst div divisor)
    (move quo eax)
    (move rem edx)))

(define-vop (signify-digit)
  (:translate sb-bignum:%fixnum-digit-with-correct-sign)
  (:policy :fast-safe)
  (:args (digit :scs (unsigned-reg unsigned-stack) :target res))
  (:arg-types unsigned-num)
  (:results (res :scs (any-reg signed-reg)
                 :load-if (not (and (sc-is digit unsigned-stack)
                                    (sc-is res control-stack signed-stack)
                                    (location= digit res)))))
  (:result-types signed-num)
  (:generator 1
    (move res digit)
    (when (sc-is res any-reg control-stack)
      (inst shl res n-fixnum-tag-bits))))

(define-vop (digit-ashr)
  (:translate sb-bignum:%ashr)
  (:policy :fast-safe)
  (:args (digit :scs (unsigned-reg unsigned-stack) :target result)
         (count :scs (unsigned-reg) :target ecx))
  (:arg-types unsigned-num positive-fixnum)
  (:temporary (:sc unsigned-reg :offset rcx-offset :from (:argument 1)) ecx)
  (:results (result :scs (unsigned-reg) :from (:argument 0)
                    :load-if (not (and (sc-is result unsigned-stack)
                                       (location= digit result)))))
  (:result-types unsigned-num)
  (:generator 2
    (move result digit)
    (move ecx count)
    (inst sar result :cl)))

(define-vop (digit-ashr/c)
  (:translate sb-bignum:%ashr)
  (:policy :fast-safe)
  (:args (digit :scs (unsigned-reg unsigned-stack) :target result))
  (:arg-types unsigned-num (:constant (integer 0 63)))
  (:info count)
  (:results (result :scs (unsigned-reg) :from (:argument 0)
                    :load-if (not (and (sc-is result unsigned-stack)
                                       (location= digit result)))))
  (:result-types unsigned-num)
  (:generator 1
    (move result digit)
    (inst sar result count)))

(define-vop (digit-lshr digit-ashr)
  (:translate sb-bignum:%digit-logical-shift-right)
  (:generator 1
    (move result digit)
    (move ecx count)
    (inst shr result :cl)))

(define-vop (digit-ashl digit-ashr)
  (:translate sb-bignum:%ashl)
  (:generator 1
    (move result digit)
    (move ecx count)
    (inst shl result :cl)))

(define-vop (logand-bignum/c)
  (:translate logand)
  (:policy :fast-safe)
  (:args (x :scs (descriptor-reg)))
  (:arg-types bignum (:constant word))
  (:results (r :scs (unsigned-reg)))
  (:info mask)
  (:result-types unsigned-num)
  (:generator 4
     (cond ((or (plausible-signed-imm32-operand-p mask)
                (location= x r))
            (loadw r x bignum-digits-offset other-pointer-lowtag)
            (unless (or (eql mask -1)
                        (eql mask (ldb (byte n-word-bits 0) -1)))
              (inst and r (constantize mask))))
           (t
            (inst mov r mask)
            (inst and r (object-slot-ea x bignum-digits-offset other-pointer-lowtag))))))

;; Specialised mask-signed-field VOPs.
(flet ((shift-unshift (reg width)
         (let ((shift (- n-word-bits width)))
           ;; Shift of 64 is effectively a shift of 0 due to masking by the CPU.
           ;; It can't happen, because size = 0 was dealt with in IR1
           (aver (/= shift 64))
           (unless (= shift 0)
             (inst shl reg shift)
             (inst sar reg shift)))))
 (define-vop (mask-signed-field-word/c)
   (:translate sb-c::mask-signed-field)
   (:policy :fast-safe)
   (:args (x :scs (signed-reg unsigned-reg any-reg) :target r))
   (:arg-types (:constant (integer 0 64)) untagged-num)
   (:results (r :scs (any-reg signed-reg)))
   (:result-types (:or tagged-num signed-num))
   (:info width)
   (:generator 3
     (case width
       ((8 16 32)
        (when (sc-is x any-reg)
          (move r x)
          (setf x r)
          (inst sar r n-fixnum-tag-bits))
        (inst movsx `(,(bits->size width) :qword) r x)
        (when (sc-is r any-reg)
          (inst shl r n-fixnum-tag-bits)))
       (t
        (let* ((shift (- n-word-bits width))
               (shift-left shift))
          (when (sc-is x any-reg)
            (decf shift-left))
          ;; Shift of 64 is effectively a shift of 0 due to masking by the CPU.
          ;; It can't happen, because size = 0 was dealt with in IR1
          (aver (/= shift 64 0))
          (cond
            ((and (not (location= r x))
                  (member shift-left '(1 2 3)))
             (inst lea r (case shift-left
                           (1 (ea x x))
                           (t
                            (ea nil x (ash 1 shift-left))))))
            (t
             (move r x)
             (inst shl r shift-left)))
          (inst sar r (if (sc-is r any-reg)
                          (- shift n-fixnum-tag-bits)
                          shift)))))))

 (define-vop (mask-signed-field-bignum/c)
   (:translate sb-c::mask-signed-field)
   (:policy :fast-safe)
   (:args (x :scs (descriptor-reg) :target r))
   (:arg-types (:constant (integer 0 64)) bignum)
   (:results (r :scs (signed-reg)))
   (:result-types signed-num)
   (:info width)
   (:generator 4
     (case width
       ((8 16 32)
        (inst movsx `(,(bits->size width) :qword)
              r (object-slot-ea x bignum-digits-offset other-pointer-lowtag)))
       (t
        (loadw r x bignum-digits-offset other-pointer-lowtag)
        (shift-unshift r width)))))

  (define-vop (mask-signed-field-integer)
    (:translate sb-c::mask-signed-field)
    (:policy :fast-safe)
    (:args (x :scs (descriptor-reg) :to :save))
    (:arg-refs x-ref)
    (:arg-types (:constant (integer 0 64)) t)
    (:results (r :scs (signed-reg any-reg)))
    (:result-types (:or signed-num tagged-num))
    (:temporary (:sc unsigned-reg
                 :unused-if (csubtypep (tn-ref-type x-ref)
                                       (specifier-type 'integer)))
                temp)
    (:info width)
    (:check-type t)
    (:save-p :compute-only)
    (:vop-var vop)
    (:generator 6
      (move r x)
      (cond ((and (sc-is r any-reg)
                  (= width n-word-bits))
             (inst test :byte r fixnum-tag-mask)
             (inst jmp :z DONE))
            (t
             (inst sar r n-fixnum-tag-bits)
             (inst jmp :nc (if (> width n-fixnum-bits)
                               DONE
                               DO))))

      (let* ((integerp (eq (tn-kind temp) :unused))
             (error (unless integerp
                      (generate-error-code vop 'object-not-integer-error x))))
        (unless integerp
          (%test-headers x temp error t nil '(#.bignum-widetag)
                         :value-tn-ref x-ref
                         :immediate-tested '(fixnum))))
      (loadw r x bignum-digits-offset other-pointer-lowtag)
      DO
      (case width
        ((8 16 32)
         (inst movsx `(,(bits->size width) :qword) r r)
         (when (sc-is r any-reg)
           (inst shl r n-fixnum-tag-bits)))
        (t
         (let ((shift (- n-word-bits width)))
           (cond
             ((zerop shift)
              (when (sc-is r any-reg)
                (inst shl r n-fixnum-tag-bits)))
             (t
              (inst shl r shift)
              (inst sar r (if (sc-is r any-reg)
                              (- shift n-fixnum-tag-bits)
                              shift)))))))
      DONE)))

(define-vop (mask-signed-field-fixnum)
  (:translate sb-c::mask-signed-field)
  (:policy :fast-safe)
  (:args (x :scs (descriptor-reg) :target r))
  (:arg-refs x-ref)
  (:arg-types (:constant (eql #.n-fixnum-bits)) t)
  (:results (r :scs (any-reg)))
  (:result-types fixnum)
  (:info width)
  (:ignore width)
  (:check-type t)
  (:save-p :compute-only)
  (:vop-var vop)
  (:temporary (:sc unsigned-reg
               :unused-if (csubtypep (tn-ref-type x-ref)
                                     (specifier-type 'integer)))
              temp)
  (:generator 5
    (move r x)
    (generate-fixnum-test r)
    (inst jmp :z DONE)
    (let* ((integerp (eq (tn-kind temp) :unused))
           (error (unless integerp
                    (generate-error-code vop 'object-not-integer-error x))))
      (unless integerp
        (%test-headers x temp error t nil '(#.bignum-widetag)
                       :value-tn-ref x-ref
                       :immediate-tested '(fixnum))))
    (loadw r r bignum-digits-offset other-pointer-lowtag)
    (inst shl r (- n-word-bits n-fixnum-bits))
    DONE))

(define-vop (logand-word-mask)
  (:translate logand)
  (:policy :fast-safe)
  (:args (x :scs (descriptor-reg) :to :save))
  (:arg-refs x-ref)
  (:arg-types t (:constant word))
  (:results (r :scs (unsigned-reg)))
  (:info mask)
  (:result-types unsigned-num)
  (:check-type t)
  (:save-p :compute-only)
  (:vop-var vop)
  (:temporary (:sc unsigned-reg
               :unused-if (csubtypep (tn-ref-type x-ref)
                                     (specifier-type 'integer)))
              temp)
  (:generator 10
    (let ((fixnum-mask-p (and (= n-fixnum-tag-bits 1)
                              (= mask (ash most-positive-word -1)))))
      (assemble ()
        (when (types-equal-or-intersect  (tn-ref-type x-ref)
                                         (specifier-type 'fixnum))
          (move r x)
          (unless (= n-fixnum-tag-bits 1)
            (generate-fixnum-test r)
            (inst jmp :nz BIGNUM))
          (if fixnum-mask-p
              (inst shr r n-fixnum-tag-bits)
              (inst sar r n-fixnum-tag-bits))
          (if (= n-fixnum-tag-bits 1)
              (inst jmp :nc DONE)
              (inst jmp DONE)))
        BIGNUM
        (let* ((integerp (eq (tn-kind temp) :unused))
               (error (unless integerp
                        (generate-error-code vop 'object-not-integer-error x))))
          (unless integerp
            (%test-headers x temp error t nil '(#.bignum-widetag)
                           :value-tn-ref x-ref
                           :immediate-tested '(fixnum))))
        (loadw r x bignum-digits-offset other-pointer-lowtag)
        (when fixnum-mask-p
          (inst btr r (1- n-word-bits)))
        DONE
        (unless (or fixnum-mask-p
                    (= mask most-positive-word))
          (if (and (not (plausible-signed-imm32-operand-p mask))
                   (= (logcount (logandc1 mask most-positive-word)) 1))
              (inst btr r (1- (integer-length (logandc1 mask most-positive-word))))
              (inst and r (or (plausible-signed-imm32-operand-p mask)
                              (constantize mask)))))))))

(define-vop (logand-word-mask/integer-unsigned)
  (:translate logand)
  (:policy :fast-safe)
  (:args (x :scs (descriptor-reg) :to :save)
         (mask :scs (unsigned-reg) :to :save))
  (:arg-refs x-ref mask-ref)
  (:arg-types t unsigned-num)
  (:results (r :scs (unsigned-reg)))
  (:result-types unsigned-num)
  (:check-type t)
  (:save-p :compute-only)
  (:vop-var vop)
  (:temporary (:sc unsigned-reg
               :unused-if (csubtypep (tn-ref-type x-ref)
                                     (specifier-type 'integer)))
              temp)
  (:generator 10
    (let ((32-bit-mask-p (or (typep mask '(unsigned-byte 32))
                             (and mask-ref
                                  (csubtypep (tn-ref-type mask-ref)
                                             (specifier-type '(unsigned-byte 32))))))
          (31-bit-mask-p (or (typep mask `(unsigned-byte ,(- 32 n-fixnum-tag-bits)))
                             (and mask-ref
                                  (csubtypep (tn-ref-type mask-ref)
                                             (specifier-type `(unsigned-byte ,(- 32 n-fixnum-tag-bits))))))))
      (assemble ()
        (when (types-equal-or-intersect  (tn-ref-type x-ref)
                                         (specifier-type 'fixnum))
          (move r x)
          (inst sar (if 31-bit-mask-p :dword :qword) r n-fixnum-tag-bits)
          (inst jmp :nc DONE))
        BIGNUM
        (let* ((integerp (eq (tn-kind temp) :unused))
               (error (unless integerp
                        (generate-error-code vop 'object-not-integer-error x))))
          (unless integerp
            (%test-headers x temp error t nil '(#.bignum-widetag)
                           :value-tn-ref x-ref
                           :immediate-tested '(fixnum))))
        (inst mov (if 32-bit-mask-p
                      :dword
                      :qword)
              r (object-slot-ea x bignum-digits-offset other-pointer-lowtag))
        DONE
        (cond ((eql mask most-positive-word))
              ((eql mask (1- (expt 2 32)))
               (inst mov :dword r r))
              ((eql mask (1- (expt 2 16)))
               (inst movzx '(:word :dword) r r))
              ((eql mask (1- (expt 2 8)))
               (inst movzx '(:byte :dword) r r))
              (t
               (inst and (if 32-bit-mask-p
                             :dword
                             :qword)
                     r mask)))))))

(defun plausible-signed-imm32-operand-or-32-mask-p (n)
  (or (eql n (1- (expt 2 32)))
      (plausible-signed-imm32-operand-p n)))

(define-vop (logand-word-mask/integer-unsigned-c logand-word-mask/integer-unsigned)
  (:args (x :scs (descriptor-reg)))
  (:info mask)
  (:arg-types t (:constant (satisfies plausible-signed-imm32-operand-or-32-mask-p))))

(define-vop (logand-word-mask/unsigned-integer logand-word-mask/integer-unsigned)
  (:args (mask :scs (unsigned-reg) :to :save)
         (x :scs (descriptor-reg) :to :save))
  (:arg-refs mask-ref x-ref)
  (:arg-types unsigned-num t))

(in-package "SB-C")

(defun *-transformer (y node fun)
  (cond
    ((= y (ash 1 (integer-length y)))
     ;; there's a generic transform for y = 2^k
     (give-up-ir1-transform))
    ((member y '(3 5 9))
     ;; we can do these multiplications directly using LEA
     (delay-ir1-transform node :constraint)
     `(,fun x x ,(1- y) 0))
    (t
     ;; A normal 64-bit multiplication takes 4 cycles on Athlon 64/Opteron.
     ;; Optimizing multiplications (other than the above cases) to
     ;; shifts/adds/leas gives a maximum improvement of 1 cycle, but requires
     ;; quite a lot of hairy code.
     (give-up-ir1-transform))))

;; These transforms were exceptionally noisy in an unhelpful way.
;; Reading the output would not induce the speed-conscious programmer to think
;; "I'd better code this multiply as (* (* B 2) 9) instead of (* B 18)
;;  so that the LEA transform kicks in".
(deftransform * ((x y)
                 ((unsigned-byte 64) (constant-arg (unsigned-byte 64)))
                 (unsigned-byte 64)
                 :important nil
                 :node node)
  "recode as leas, shifts and adds"
  (*-transformer (lvar-value y) node '%lea))
(deftransform sb-vm::*-mod64
    ((x y) ((unsigned-byte 64) (constant-arg (unsigned-byte 64)))
     (unsigned-byte 64)
     :important nil
     :node node)
  "recode as leas, shifts and adds"
  (*-transformer (lvar-value y) node 'sb-vm::%lea-mod64))

(deftransform * ((x y)
                 (fixnum (constant-arg (unsigned-byte 64)))
                 fixnum
                 :important nil
                 :node node)
  "recode as leas, shifts and adds"
  (*-transformer (lvar-value y) node '%lea))
(deftransform sb-vm::*-modfx
    ((x y) (fixnum (constant-arg (unsigned-byte 64)))
     fixnum
     :important nil
     :node node)
  "recode as leas, shifts and adds"
  (*-transformer (lvar-value y) node 'sb-vm::%lea-modfx))

(defun exactly-one-read-p (results)
  (when results
    (let ((refs (tn-reads (tn-ref-tn results))))
      ;; How can REFS be NIL? I don't understand.
      (and refs (not (tn-ref-next refs))))))

;;; When writing to a bitfield, msan tracks precisely which of
;;; the bits in a byte have been written, as mentioned in the paper:
;;; (https://static.googleusercontent.com/media/research.google.com/en//pubs/archive/43308.pdf)
;;; "For example, bit shifts and bit logic operations are often used
;;; to extract individual field from bitfields. As adjacent fields
;;; may be not initialized, it is important that the result shadow
;;; matches the exact bits occupied by a particular field."
;;; SAP-REF- has to respect the exactness by not complaining about bits which
;;; have not been written if the intent is not to read them.
;;; So given a VOP which is some sap-ref, if the result flows into a LOGAND,
;;; then it's a masked load and we do not read the shadow of the
;;; bits that are masked off.
(defun masked-memory-load-p (vop)
  (let ((next-vop (vop-next vop))
        next-next-vop)
    (case (and next-vop (vop-info-name (vop-info next-vop)))
      ((sb-vm::fast-logand-c/unsigned=>unsigned
        sb-vm::fast-logand-c/signed-unsigned=>unsigned)
       (when (exactly-one-read-p (vop-results vop))
         (car (vop-codegen-info next-vop))))
      (sb-vm::move-from-word/fixnum
       ;; The result of this vop has to have exactly 1 read
       ;; (the MOVE-FROM-WORD) and the result of that has to
       ;; have exactly one read (the LOGAND)
       (when (and (exactly-one-read-p (vop-results vop))
                  (setq next-next-vop (vop-next next-vop))
                  (eq (vop-info-name (vop-info next-next-vop))
                      'sb-vm::fast-logand-c/fixnum=>fixnum)
                  (exactly-one-read-p (vop-results next-vop)))
         (car (vop-codegen-info next-next-vop)))))))

(in-package :sb-vm)

(macrolet ((def (name excl-low excl-high &optional check)
             `(progn
                ,(unless check
                   `(define-vop (,(symbolicate name '/c))
                      (:translate ,name)
                      (:args (x :scs (any-reg signed-reg unsigned-reg)))
                      (:arg-refs x-ref)
                      (:arg-types (:constant t)
                                  (:or tagged-num signed-num unsigned-num)
                                  (:constant t))
                      (:info lo hi)
                      (:temporary (:sc signed-reg) temp)
                      (:temporary (:sc signed-reg) temp2)
                      (:conditional :be)
                      (:vop-var vop)
                      (:policy :fast-safe)
                      (:generator 2
                        (let ((lo (+ lo ,@(and excl-low
                                               '(1))))
                              (hi (+ hi ,@(and excl-high
                                               '(-1))))
                              (int (sb-c::type-approximate-interval (tn-ref-type x-ref))))
                          (flet ((imm (x)
                                   (cond ((plausible-signed-imm32-operand-p x)
                                          x)
                                         (t
                                          (inst mov temp2 x)
                                          temp2))))
                            (multiple-value-bind (flo fhi)
                                (if (sc-is x any-reg)
                                    (values (fixnumize lo) (fixnumize hi))
                                    (values lo hi))
                              (cond
                                ((= lo hi)
                                 (inst cmp x (imm flo))
                                 (change-vop-flags vop '(:e)))
                                ((sb-c::interval-high<=n int hi)
                                 (cond ((eql lo 1)
                                        (change-vop-flags vop '(:g))
                                        (inst test x x))
                                       (t
                                        (change-vop-flags vop '(:ge))
                                        (inst cmp x (imm flo)))))
                                ((and (sb-c::interval-low>=n int lo)
                                      (cond ((< lo 0))
                                            (t
                                             (setf lo 0
                                                   flo 0)
                                             nil)))
                                 (change-vop-flags vop '(:le))
                                 (inst cmp x (imm fhi)))
                                ((or (< hi lo)
                                     (and (sc-is x unsigned-reg)
                                          (< hi 0)))
                                 (inst cmp rsp-tn 0))
                                ((= lo 0)
                                 (cond ((and (sc-is x any-reg)
                                             (= hi most-positive-fixnum))
                                        (inst test x x)
                                        (change-vop-flags vop '(:ge)))
                                       ((and (= (logcount (+ hi 1)) 1)
                                             (> fhi 127))
                                        (change-vop-flags vop '(:e))
                                        (move temp x)
                                        (inst shr temp (integer-length fhi)))
                                       (t
                                        (inst cmp x (imm fhi)))))
                                ((= hi -1)
                                 (change-vop-flags vop '(:ae))
                                 (inst cmp x (imm flo)))
                                (t
                                 (if (location= temp x)
                                     (if (plusp flo)
                                         (inst sub temp (imm flo))
                                         (inst add temp (imm (- flo))))
                                     (inst lea temp (ea (imm (- flo)) x)))
                                 (inst cmp temp (imm (- fhi flo)))))))))))

                (define-vop (,(symbolicate name '-integer/c))
                  (:translate ,name)
                  (:args (x :scs (descriptor-reg)))
                  (:arg-refs x-ref)
                  (:arg-types (:constant t) ,(if check
                                                 t
                                                 `(:or integer bignum))
                              (:constant t))
                  (:info target not-p lo hi)
                  (:temporary (:sc signed-reg) temp)
                  (:temporary (:sc signed-reg) temp2)
                  (:conditional)
                  (:vop-var vop)
                  (:policy :fast-safe)
                  (:generator 5
                    (let* ((orig-lo (+ lo ,@ (and excl-low
                                                  `(1))))
                           (orig-hi (+ hi ,@ (and excl-high
                                                  `(-1))))
                           (lo (fixnumize orig-lo))
                           (hi (fixnumize orig-hi))
                           (lowest-bignum-address (cond
                                                    ,@(and check
                                                           #.(progn (assert
                                                                     (< single-float-widetag character-widetag))
                                                                    t)
                                                           `(((types-equal-or-intersect (tn-ref-type x-ref) (specifier-type 'single-float))
                                                              single-float-widetag)
                                                             ((types-equal-or-intersect (tn-ref-type x-ref) (specifier-type 'character))
                                                              character-widetag)))
                                                    (t
                                                     +backend-page-bytes+)))
                           (int (sb-c::type-approximate-interval (tn-ref-type x-ref))))
                      (when (sb-c::interval-low>=n int orig-lo)
                        (setf lo (if (>= orig-lo 0)
                                     0
                                     ,(fixnumize most-negative-fixnum))))
                      (when (sb-c::interval-high<=n int orig-hi)
                        (setf hi ,(fixnumize most-positive-fixnum)))
                      (flet ((imm (x &optional (const t) (temp temp2))
                               (cond ((plausible-signed-imm32-operand-p x)
                                      x)
                                     (const
                                      (constantize x))
                                     (t
                                      (inst mov temp x)
                                      temp)))
                             (test-fixnum ()
                               (unless (and (< -1 lo lowest-bignum-address)
                                            (< -1 hi lowest-bignum-address))
                                 (generate-fixnum-test x)
                                 (inst jmp :ne (if not-p target skip)))))
                        (cond ((< hi lo)
                               (inst jmp (if not-p target skip)))
                              ((= lo hi)
                               (inst cmp x (imm lo))
                               (inst jmp (if not-p :ne :e) target))
                              ((= hi ,(fixnumize -1))
                               (test-fixnum)
                               (inst cmp x (imm lo))
                               (inst jmp (if not-p :b :ae) target))
                              ((= lo ,(fixnumize most-negative-fixnum))
                               (test-fixnum)
                               (inst cmp x (imm hi))
                               (inst jmp (if not-p :g :le) target))
                              ((and (if (= hi ,(fixnumize most-positive-fixnum))
                                        (/= lo 0)
                                        (> lo 0))
                                    (= (logcount (+ hi (fixnumize 1))) 1)
                                    (>= hi lowest-bignum-address))
                               (if (= hi ,(fixnumize most-positive-fixnum))
                                   (inst test :byte x n-fixnum-tag-bits)
                                   (inst test x (imm (lognot hi))))
                               (inst jmp :ne (if not-p target skip))
                               (let ((size (if (typep hi '(unsigned-byte 32))
                                               :dword
                                               :qword)))
                                 (cond
                                   ((eq lo (fixnumize 1))
                                    (inst test size x x)
                                    (inst jmp (if (eq size :dword)
                                                  (if not-p :z :nz)
                                                  (if not-p :le :g)) target))
                                   (t
                                    (inst cmp size x (imm lo))
                                    (inst jmp (if (eq size :dword)
                                                  (if not-p :b :ae)
                                                  (if not-p :l :ge)) target)))))
                              (t
                               (if (= lo 0)
                                   (setf temp x)
                                   (if (location= temp x)
                                       (if (plusp lo)
                                           (inst sub temp (imm lo))
                                           (inst add temp (imm (- lo))))
                                       (let ((imm (imm (- lo) nil temp)))
                                         (if (integerp imm)
                                             (inst lea temp (ea imm  x))
                                             (inst add temp x)))))
                               (let ((diff (- hi lo)))
                                 (cond ((= diff (fixnumize most-positive-fixnum))
                                        (test-fixnum)
                                        (inst test temp temp)
                                        (inst jmp (if not-p :l :ge) target))
                                       ((= (logcount (+ diff (fixnumize 1))) 1)
                                        (inst test temp (imm (lognot diff)))
                                        (inst jmp (if not-p :ne :e) target))
                                       (t
                                        (test-fixnum)
                                        (inst cmp temp (imm diff))
                                        (inst jmp (if not-p :a :be) target))))))))
                    skip)))))

  (def range< t t)
  (def range<= nil nil)
  (def range<<= t nil)
  (def range<=< nil t)

  (def check-range<= nil nil t))

(deftransform %dpb ((new size posn integer) (:or (((constant-arg integer)
                                                   (constant-arg (integer 1 1))
                                                   word
                                                   word) word)
                                                 (((constant-arg integer)
                                                   (constant-arg (integer 1 1))
                                                   word
                                                   signed-word) signed-word)) *
                    :vop t)
  (not (constant-lvar-p posn)))

(define-vop (dpb-c/fixnum)
  (:translate %dpb)
  (:args (posn :scs (unsigned-reg) :target temp)
         (y :scs (any-reg) :target res))
  (:arg-refs posn-ref)
  (:arg-types (:constant integer)
              (:constant (integer 1 1))
              unsigned-num
              tagged-num)
  (:info new size)
  (:ignore size)
  (:temporary (:sc unsigned-reg :from (:argument 0)) temp)
  (:results (res :scs (any-reg)))
  (:result-types tagged-num)
  (:policy :fast-safe)
  (:generator 2
    (move res y)
    (unless (csubtypep (tn-ref-type posn-ref) (specifier-type '(mod 64)))
      (inst cmp posn 64)
      (inst jmp :ae done))
    (if (location= posn temp)
        (inst inc :dword temp)
        (inst lea :dword temp (ea 1 posn)))
    (if (logbitp 0 new)
        (inst bts res temp)
        (inst btr res temp))
    DONE))

(define-vop (dpb-c/unsigned)
  (:translate %dpb)
  (:args (posn :scs (unsigned-reg) :to :save)
         (y :scs (unsigned-reg) :target res))
  (:arg-refs posn-ref)
  (:arg-types (:constant integer)
              (:constant (integer 1 1)) unsigned-num
              unsigned-num)
  (:info new size)
  (:ignore size)
  (:results (res :scs (unsigned-reg)))
  (:result-types unsigned-num)
  (:policy :fast-safe)
  (:generator 3
    (move res y)
    (unless (csubtypep (tn-ref-type posn-ref) (specifier-type '(mod 64)))
      (inst cmp posn 64)
      (inst jmp :ae done))
    (if (logbitp 0 new)
        (inst bts res posn)
        (inst btr res posn))
    DONE))

(define-vop (dpb-c/signed)
  (:translate %dpb)
  (:args (posn :scs (unsigned-reg) :to :save)
         (y :scs (signed-reg) :target res))
  (:arg-refs posn-ref)
  (:arg-types (:constant integer)
              (:constant (integer 1 1))
              unsigned-num
              signed-num)
  (:info new size)
  (:ignore size)
  (:results (res :scs (signed-reg)))
  (:result-types signed-num)
  (:policy :fast-safe)
  (:generator 3
    (move res y)
    (unless (csubtypep (tn-ref-type posn-ref) (specifier-type '(mod 64)))
      (inst cmp posn 64)
      (inst jmp :ae done))
    (if (logbitp 0 new)
        (inst bts res posn)
        (inst btr res posn))
    DONE))

(defknown calc-phash ((unsigned-byte 32) (integer 1 4) simple-vector)
  (unsigned-byte 32) (flushable always-translatable))

;;; TODO: sometimes there's (LDB (BYTE 32 0) KEY) in front of the calculation
;;; which we don't need, or rather, need but can be done in the vop basically
;;; for free compared to referencing #x1FFFFFFFE as a code header constant.
;;; Even if the initial untagging right-shift is required to use a :QWORD
;;; operand size, it could be followed by a :DWORD mov into the same register.
(define-vop ()
  (:translate calc-phash)
  (:args (arg :scs (any-reg) :target temp0))
  (:arg-types positive-fixnum (:constant t) (:constant t))
  (:info n-temps steps)
  (:ignore n-temps)
  (:temporary (:sc unsigned-reg :from (:argument 0) :to (:result 0))
              temp0 temp1)
  (:temporary (:sc unsigned-reg :from (:argument 0) :to (:result 0)
               :unused-if (< n-temps 3)) temp2)
  (:temporary (:sc unsigned-reg :from (:argument 0) :to (:result 0)
               :unused-if (< n-temps 4)) temp3)
  (:results (res :scs (any-reg)))
  (:result-types positive-fixnum)
  (:policy :fast-safe)
  (:generator 3
    (aver (eq (cadr (svref steps 0)) 'sb-c::t0))
    ;; this should be a null move due to :target on arg
    (move temp0 arg)
    (flet ((tn-from-metasyntactic-var (var)
             (ecase var
               (sb-c::t0 temp0)
               (sb-c::t1 temp1)
               (sb-c::t2 temp2)
               (sb-c::t3 temp3))))
      ;; Replace placeholder symbols with TNs, and perform a few assembly tricks
      (do ((i 0 (1+ i))
           (prev-op))
          ((= i (length steps)))
        (destructuring-bind (&whole stmt op arg1 &optional arg2 arg3) (svref steps i)
          (declare (ignore arg3))
          (when (eq op 'move) ; MOVE becomes MOV
            (setf op 'mov (first stmt) op))
          (when (symbolp arg1)
            (setf arg1 (tn-from-metasyntactic-var arg1)
                  (second stmt) arg1))
          (when (setf arg2 (typecase arg2
                             ((and symbol (not null)) (tn-from-metasyntactic-var arg2))
                             (array (emit-constant arg2))
                             (t arg2)))
            (setf (third stmt) arg2))
          ;; ANDing with #xFF or #xFFFF is MOVZX, and might subsume a MOV too,
          ;; but MOV / AND #xFF is so rare that I couldn't make it occur.
          (when (and (eq op 'and) (or (eql arg2 #xFF) (eql arg2 #xFFFF)))
            ;; Emit as MOVZX which avoids using a 4-byte immediate in the AND.
            ;; (A 1-byte immediate would get sign-extended)
            (let ((size (if (eql arg2 #xFF) :byte :word)))
              (setf (svref steps i) `(movzx (,size :dword) ,arg1 ,arg1))))
          (setq prev-op op))))
    ;; Emit instructions
    (dotimes (i (length steps))
      (destructuring-bind (&whole stmt op dest &optional src arg3) (svref steps i)
        (cond ((eq op 'sb-c::neg) ; unary op
               (inst neg :dword dest))
              ((eq op 'aref)
               (let* ((disp (- (ash vector-data-offset word-shift)
                               other-pointer-lowtag)) ; complicated way of computing 1
                      (scale arg3)
                      (ea (ea disp dest src scale)))
                 (ecase scale
                   (1 (inst movzx '(:byte :dword) dest ea))
                   (2 (inst movzx '(:word :dword) dest ea))
                   (4 (inst mov :dword dest ea)))))
              ((or (eq op 'movzx) (and (eq op 'mov) (constant-tn-p src)))
               (apply #'inst* stmt)) ; zero-extending or 64-bit move
              ((eq i 0)
               (aver (eq op 'sb-c::shr))
               ;; fixnum-untagging MOV is 64-bit to avoid losing 1 bit,
               ;; unless I can show that the expression doesn't care about bit 31
               (inst* op dest src))
              ((and (eq op 'sb-c::xor) (eql src #xFFFFFFFF))
               (inst not :dword dest))
              (t
               (inst* op :dword dest src)))))
    ;; Move result and re-tag. Restrict the output to 31 significant bits,
    ;; totally reasonable considering that you'd probably have to wait for
    ;; days to produce a perfect hash function of 2 billion keys.
    (let* ((step (svref steps (1- (length steps))))
           (tn (second step)))
      (if (location= res tn)
          (inst add :dword res tn)
          (inst lea :dword res (ea tn tn))))))

(defknown zero-or-one ((unsigned-byte 32))
    (integer 0 1)
    (flushable))
(define-vop (zero-or-one/ub32)
  (:translate zero-or-one)
  (:policy :fast-safe)
  (:args (arg :scs (unsigned-reg)))
  (:arg-types unsigned-num)
  (:results (res :scs (unsigned-reg)))
  (:result-types unsigned-num)
  (:generator 1
   (cond ((location= res arg)
          (inst test arg arg)
          (inst mov arg 0)
          (inst set :nz arg))
         (t
          (inst xor res res)
          (inst test arg arg)
          (inst set :nz res)))))

(define-vop ()
  (:policy :fast-safe)
  (:translate rotate-right-word)
  (:args (integer :scs (unsigned-reg) :target result))
  (:info count)
  (:arg-types unsigned-num (:constant (mod 64)))
  (:results (result :scs (unsigned-reg)))
  (:result-types unsigned-num)
  (:generator 5
    (aver (not (= count 0)))
    (move result integer)
    (inst ror result count)))

(define-vop ()
  (:policy :fast-safe)
  (:translate ash-right-two-words)
  (:args (a :scs (unsigned-reg) :to :save)
         (b :scs (unsigned-reg) :target result))
  (:info count)
  (:arg-types unsigned-num unsigned-num (:constant (mod 64)))
  (:results (result :scs (unsigned-reg)))
  (:result-types unsigned-num)
  (:generator 1
    (move result b)
    (inst shrd result a count)))

(define-vop (ash-right-two-words-variable)
  (:policy :fast-safe)
  (:translate ash-right-two-words)
  (:args (a :scs (unsigned-reg) :to :save)
         (b :scs (unsigned-reg) :target result)
         (count :scs (unsigned-reg) :target ecx))
  (:temporary (:sc unsigned-reg :offset rcx-offset :from (:argument 2)) ecx)
  (:arg-types unsigned-num unsigned-num unsigned-num)
  (:results (result :scs (unsigned-reg)))
  (:result-types unsigned-num)
  (:generator 2
    (move result b)
    (move ecx count :dword)
    (inst shrd result a :cl)))

;; Based on TargetLowering::expandBITREVERSE in llvm/lib/CodeGen/SelectionDAG/TargetLowering.cpp
(define-vop ()
  (:translate reverse-bits-64)
  (:policy :fast-safe)
  (:args (arg :scs (unsigned-reg)))
  (:arg-types unsigned-num)
  (:results (res :scs (unsigned-reg)))
  (:result-types unsigned-num)
  (:temporary (:sc unsigned-reg) temp1 temp2 temp3)
  (:generator 20
    (move temp1 arg)
    (inst bswap temp1)
    (inst mov temp2 temp1)
    (inst shr temp2 4)
    (inst mov temp3 #xF0F0F0F0F0F0F0F)
    (inst and temp2 temp3)
    (inst and temp1 temp3)
    (inst shl temp1 4)
    (inst or temp1 temp2)
    (inst mov temp2 #x3333333333333333)
    (inst mov temp3 temp1)
    (inst and temp3 temp2)
    (inst shr temp1 2)
    (inst and temp1 temp2)
    (inst lea temp2 (ea temp1 temp3 4))
    (inst mov temp3 #x5555555555555555)
    (inst mov res temp2)
    (inst and res temp3)
    (inst shr temp2 1)
    (inst and temp2 temp3)
    (inst lea res (ea temp2 res 2))))

(deftransform abs ((x) (:or ((signed-word) signed-word)) * :vop t)
  t)

(define-vop (abs)
  (:translate abs)
  (:policy :fast-safe)
  (:args (x :scs (signed-reg)))
  (:arg-refs x-ref)
  (:arg-types signed-num)
  (:results (res :scs (signed-reg)))
  (:temporary (:sc unsigned-reg) temp)
  (:result-types signed-num)
   (:generator 2
    (move res x)
    (move temp x)
    (inst neg temp)
    (inst cmov :g res temp)))

(define-vop (abs-fixnum abs)
  (:args (x :scs (any-reg)))
  (:arg-types tagged-num)
  (:results (res :scs (any-reg)))
  (:result-types tagged-num)
   (:variant-cost 1))
