arith.lisp

开源跨平台Lisp编译器

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

(define-vop (fast-conditional/unsigned fast-conditional)
  (:args (x :scs (unsigned-reg)
            :load-if (not (and (sc-is x unsigned-stack)
                               (sc-is y unsigned-reg))))
         (y :scs (unsigned-reg unsigned-stack)))
  (:arg-types unsigned-num unsigned-num)
  (:note "inline (unsigned-byte 32) comparison"))

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

(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)
                         (:generator ,cost
                          (emit-optimized-test-inst x
                                                    ,(if (eq suffix '-c/fixnum)
                                                         '(fixnumize y)
                                                         'y))
                          (inst jmp (if not-p :e :ne) target)))))))
  (define-logtest-vops))

(defknown %logbitp (integer unsigned-byte) boolean
  (movable foldable flushable always-translatable))

;;; only for constant folding within the compiler
(defun %logbitp (integer index)
  (logbitp index integer))

;;; too much work to do the non-constant case (maybe?)
(define-vop (fast-logbitp-c/fixnum fast-conditional-c/fixnum)
  (:translate %logbitp)
  (:arg-types tagged-num (:constant (integer 0 29)))
  (:generator 4
    (inst bt x (+ y n-fixnum-tag-bits))
    (inst jmp (if not-p :nc :c) target)))

(define-vop (fast-logbitp/signed fast-conditional/signed)
  (:args (x :scs (signed-reg signed-stack))
         (y :scs (signed-reg)))
  (:translate %logbitp)
  (:generator 6
    (inst bt x y)
    (inst jmp (if not-p :nc :c) target)))

(define-vop (fast-logbitp-c/signed fast-conditional-c/signed)
  (:translate %logbitp)
  (:arg-types signed-num (:constant (integer 0 31)))
  (:generator 5
    (inst bt x y)
    (inst jmp (if not-p :nc :c) target)))

(define-vop (fast-logbitp/unsigned fast-conditional/unsigned)
  (:args (x :scs (unsigned-reg unsigned-stack))
         (y :scs (unsigned-reg)))
  (:translate %logbitp)
  (:generator 6
    (inst bt x y)
    (inst jmp (if not-p :nc :c) target)))

(define-vop (fast-logbitp-c/unsigned fast-conditional-c/unsigned)
  (:translate %logbitp)
  (:arg-types unsigned-num (:constant (integer 0 31)))
  (:generator 5
    (inst bt x y)
    (inst jmp (if not-p :nc :c) target)))

(macrolet ((define-conditional-vop (tran cond unsigned not-cond not-unsigned)
             `(progn
                ,@(mapcar
                   (lambda (suffix cost signed)
                     `(define-vop (;; FIXME: These could be done more
                                   ;; cleanly with SYMBOLICATE.
                                   ,(intern (format nil "~:@(FAST-IF-~A~A~)"
                                                    tran suffix))
                                   ,(intern
                                     (format nil "~:@(FAST-CONDITIONAL~A~)"
                                             suffix)))
                        (:translate ,tran)
                        (:generator ,cost
                                    (inst cmp x
                                          ,(if (eq suffix '-c/fixnum)
                                               '(fixnumize y)
                                               'y))
                                    (inst jmp (if not-p
                                                  ,(if signed
                                                       not-cond
                                                       not-unsigned)
                                                  ,(if signed
                                                       cond
                                                       unsigned))
                                          target))))
                   '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned)
                   '(4 3 6 5 6 5)
                   '(t t t t nil nil)))))

  (define-conditional-vop < :l :b :ge :ae)
  (define-conditional-vop > :g :a :le :be))

(define-vop (fast-if-eql/signed fast-conditional/signed)
  (:translate eql)
  (:generator 6
    (inst cmp x y)
    (inst jmp (if not-p :ne :e) target)))

(define-vop (fast-if-eql-c/signed fast-conditional-c/signed)
  (:translate eql)
  (:generator 5
    (cond ((and (sc-is x signed-reg) (zerop y))
           (inst test x x))  ; smaller instruction
          (t
           (inst cmp x y)))
    (inst jmp (if not-p :ne :e) target)))

(define-vop (fast-if-eql/unsigned fast-conditional/unsigned)
  (:translate eql)
  (:generator 6
    (inst cmp x y)
    (inst jmp (if not-p :ne :e) target)))

(define-vop (fast-if-eql-c/unsigned fast-conditional-c/unsigned)
  (:translate eql)
  (:generator 5
    (cond ((and (sc-is x unsigned-reg) (zerop y))
           (inst test x x))  ; smaller instruction
          (t
           (inst cmp x y)))
    (inst jmp (if not-p :ne :e) target)))

;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a
;;; known fixnum.

;;; These versions specify a fixnum restriction on their first arg. We have
;;; also generic-eql/fixnum VOPs which are the same, but have no restriction on
;;; the first arg and a higher cost. The reason for doing this is to prevent
;;; fixnum specific operations from being used on word integers, spuriously
;;; consing the argument.

(define-vop (fast-eql/fixnum fast-conditional)
  (:args (x :scs (any-reg)
            :load-if (not (and (sc-is x control-stack)
                               (sc-is y any-reg))))
         (y :scs (any-reg control-stack)))
  (:arg-types tagged-num tagged-num)
  (:note "inline fixnum comparison")
  (:translate eql)
  (:generator 4
    (inst cmp x y)
    (inst jmp (if not-p :ne :e) target)))
(define-vop (generic-eql/fixnum fast-eql/fixnum)
  (:args (x :scs (any-reg descriptor-reg)
            :load-if (not (and (sc-is x control-stack)
                               (sc-is y any-reg))))
         (y :scs (any-reg control-stack)))
  (:arg-types * tagged-num)
  (:variant-cost 7))

(define-vop (fast-eql-c/fixnum fast-conditional/fixnum)
  (:args (x :scs (any-reg control-stack)))
  (:arg-types tagged-num (:constant (signed-byte 30)))
  (:info target not-p y)
  (:translate eql)
  (:generator 2
    (cond ((and (sc-is x any-reg) (zerop y))
           (inst test x x))  ; smaller instruction
          (t
           (inst cmp x (fixnumize y))))
    (inst jmp (if not-p :ne :e) target)))
(define-vop (generic-eql-c/fixnum fast-eql-c/fixnum)
  (:args (x :scs (any-reg descriptor-reg control-stack)))
  (:arg-types * (:constant (signed-byte 30)))
  (:variant-cost 6))

;;;; 32-bit logical operations

(define-vop (merge-bits)
  (:translate merge-bits)
  (:args (shift :scs (signed-reg unsigned-reg) :target ecx)
         (prev :scs (unsigned-reg) :target result)
         (next :scs (unsigned-reg)))
  (:arg-types tagged-num unsigned-num unsigned-num)
  (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 0)) ecx)
  (:results (result :scs (unsigned-reg) :from (:argument 1)))
  (:result-types unsigned-num)
  (:policy :fast-safe)
  (:generator 4
    (move ecx shift)
    (move result prev)
    (inst shrd result next :cl)))

;;; Only the lower 5 bits of the shift amount are significant.
(define-vop (shift-towards-someplace)
  (:policy :fast-safe)
  (:args (num :scs (unsigned-reg) :target r)
         (amount :scs (signed-reg) :target ecx))
  (:arg-types unsigned-num tagged-num)
  (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx)
  (:results (r :scs (unsigned-reg) :from (:argument 0)))
  (:result-types unsigned-num))

(define-vop (shift-towards-start shift-towards-someplace)
  (:translate shift-towards-start)
  (:note "SHIFT-TOWARDS-START")
  (:generator 1
    (move r num)
    (move ecx amount)
    (inst shr r :cl)))

(define-vop (shift-towards-end shift-towards-someplace)
  (:translate shift-towards-end)
  (:note "SHIFT-TOWARDS-END")
  (:generator 1
    (move r num)
    (move ecx amount)
    (inst shl r :cl)))

;;;; Modular functions
(defmacro define-mod-binop ((name prototype) function)
  `(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)))
(defmacro define-mod-binop-c ((name prototype) function)
  `(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 r unsigned-stack)
                                        (sc-is r signed-stack))
                                    (location= x r)))))
     (:info y)
     (:arg-types untagged-num (:constant (or (unsigned-byte 32) (signed-byte 32))))
     (: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 r unsigned-stack)
                                         (sc-is r unsigned-stack))
                                     (location= x r)))))
     (:result-types unsigned-num)
     (:translate ,function)))

(macrolet ((def (name -c-p)
             (let ((fun32 (intern (format nil "~S-MOD32" name)))
                   (vopu (intern (format nil "FAST-~S/UNSIGNED=>UNSIGNED" name)))
                   (vopcu (intern (format nil "FAST-~S-C/UNSIGNED=>UNSIGNED" name)))
                   (vopf (intern (format nil "FAST-~S/FIXNUM=>FIXNUM" name)))
                   (vopcf (intern (format nil "FAST-~S-C/FIXNUM=>FIXNUM" name)))
                   (vop32u (intern (format nil "FAST-~S-MOD32/WORD=>UNSIGNED" name)))
                   (vop32f (intern (format nil "FAST-~S-MOD32/FIXNUM=>FIXNUM" name)))
                   (vop32cu (intern (format nil "FAST-~S-MOD32-C/WORD=>UNSIGNED" name)))
                   (vop32cf (intern (format nil "FAST-~S-MOD32-C/FIXNUM=>FIXNUM" name)))
                   (sfun30 (intern (format nil "~S-SMOD30" name)))
                   (svop30f (intern (format nil "FAST-~S-SMOD30/FIXNUM=>FIXNUM" name)))
                   (svop30cf (intern (format nil "FAST-~S-SMOD30-C/FIXNUM=>FIXNUM" name))))
               `(progn
                  (define-modular-fun ,fun32 (x y) ,name :untagged nil 32)
                  (define-modular-fun ,sfun30 (x y) ,name :tagged t 30)
                  (define-mod-binop (,vop32u ,vopu) ,fun32)
                  (define-vop (,vop32f ,vopf) (:translate ,fun32))
                  (define-vop (,svop30f ,vopf) (:translate ,sfun30))
                  ,@(when -c-p
                      `((define-mod-binop-c (,vop32cu ,vopcu) ,fun32)
                        (define-vop (,svop30cf ,vopcf) (:translate ,sfun30))))))))
  (def + t)
  (def - t)
  ;; (no -C variant as x86 MUL instruction doesn't take an immediate)
  (def * nil))


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

(define-vop (fast-ash-left-mod32/unsigned=>unsigned
             fast-ash-left/unsigned=>unsigned))
(deftransform ash-left-mod32 ((integer count)
                              ((unsigned-byte 32) (unsigned-byte 5)))
  (when (sb!c::constant-lvar-p count)
    (sb!c::give-up-ir1-transform))
  '(%primitive fast-ash-left-mod32/unsigned=>unsigned integer count))

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

(define-vop (fast-ash-left-smod30/fixnum=>fixnum
             fast-ash-left/fixnum=>fixnum))
(deftransform ash-left-smod30 ((integer count)
                               ((signed-byte 30) (unsigned-byte 5)))
  (when (sb!c::constant-lvar-p count)
    (sb!c::give-up-ir1-transform))
  '(%primitive fast-ash-left-smod30/fixnum=>fixnum integer count))

(in-package "SB!C")

(defknown sb!vm::%lea-mod32 (integer integer (member 1 2 4 8) (signed-byte 32))
  (unsigned-byte 32)
  (foldable flushable movable))
(defknown sb!vm::%lea-smod30 (integer integer (member 1 2 4 8) (signed-byte 32))
  (signed-byte 30)
  (foldable flushable movable))

(define-modular-fun-optimizer %lea ((base index scale disp) :untagged nil :width width)
  (when (and (<= width 32)
             (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-mod32))
(define-modular-fun-optimizer %lea ((base index scale disp) :tagged t :width width)
  (when (and (<= width 30)
             (constant-lvar-p scale)
             (constant-lvar-p disp))
    (cut-to-width base :tagged width t)
    (cut-to-width index :tagged width t)