(inst jmp dest)))
\f
+;;;; Generic conditional VOPs
+
+;;; The generic conditional branch, emitted immediately after test
+;;; VOPs that only set flags.
+;;;
+;;; FLAGS is a list of condition descriptors. If the first descriptor
+;;; is CL:NOT, the test was true if all the remaining conditions are
+;;; false. Otherwise, the test was true if any of the conditions is.
+;;;
+;;; NOT-P flips the meaning of the test, as with regular :CONDITIONAL
+;;; VOP. If NOT-P is true, the code must branch to dest if the test was
+;;; false. Otherwise, the code must branch to dest if the test was true.
+
+(define-vop (branch-if)
+ (:info dest flags not-p)
+ (:generator 0
+ (when (eq (car flags) 'not)
+ (pop flags)
+ (setf not-p (not not-p)))
+ (flet ((negate-condition (name)
+ (let ((code (logxor 1 (conditional-opcode name))))
+ (aref *condition-name-vec* code))))
+ (cond ((null (rest flags))
+ (inst jmp
+ (if not-p
+ (negate-condition (first flags))
+ (first flags))
+ dest))
+ (not-p
+ (let ((not-lab (gen-label))
+ (last (car (last flags))))
+ (dolist (flag (butlast flags))
+ (inst jmp flag not-lab))
+ (inst jmp (negate-condition last) dest)
+ (emit-label not-lab)))
+ (t
+ (dolist (flag flags)
+ (inst jmp flag dest)))))))
+
+(defvar *cmov-ptype-representation-vop*
+ (mapcan (lambda (entry)
+ (destructuring-bind (ptypes &optional sc vop)
+ entry
+ (unless (listp ptypes)
+ (setf ptypes (list ptypes)))
+ (mapcar (if (and vop sc)
+ (lambda (ptype)
+ (list ptype sc vop))
+ #'list)
+ ptypes)))
+ '((t descriptor-reg move-if/t)
+
+ ((fixnum positive-fixnum)
+ any-reg move-if/fx)
+ ((unsigned-byte-64 unsigned-byte-63)
+ unsigned-reg move-if/unsigned)
+ (signed-byte-64 signed-reg move-if/signed)
+ ;; FIXME: Can't use CMOV with byte registers, and characters live
+ ;; in such outside of unicode builds. A better solution then just
+ ;; disabling MOVE-IF/CHAR should be possible, though.
+ #!+sb-unicode
+ (character character-reg move-if/char)
+
+ ((single-float complex-single-float
+ double-float complex-double-float))
+
+ (system-area-pointer sap-reg move-if/sap)))
+ "Alist of primitive type -> (storage-class-name VOP-name)
+ if values of such a type should be cmoved, and NIL otherwise.
+
+ storage-class-name is the name of the storage class to use for
+ the values, and VOP-name the name of the VOP that will be used
+ to execute the conditional move.")
+
+(!def-vm-support-routine
+ convert-conditional-move-p (node dst-tn x-tn y-tn)
+ (declare (ignore node))
+ (let* ((ptype (sb!c::tn-primitive-type dst-tn))
+ (name (sb!c::primitive-type-name ptype))
+ (param (cdr (or (assoc name *cmov-ptype-representation-vop*)
+ '(t descriptor-reg move-if/t)))))
+ (when param
+ (destructuring-bind (representation vop) param
+ (let ((scn (sc-number-or-lose representation)))
+ (labels ((make-tn ()
+ (make-representation-tn ptype scn))
+ (frob-tn (tn)
+ (if (immediate-tn-p tn)
+ tn
+ (make-tn))))
+ (values vop
+ (frob-tn x-tn) (frob-tn y-tn)
+ (make-tn)
+ nil)))))))
+
+(define-vop (move-if)
+ (:args (then) (else))
+ (:results (res))
+ (:info flags)
+ (:generator 0
+ (let ((not-p (eq (first flags) 'not)))
+ (when not-p (pop flags))
+ (flet ((negate-condition (name)
+ (let ((code (logxor 1 (conditional-opcode name))))
+ (aref *condition-name-vec* code)))
+ (load-immediate (dst constant-tn
+ &optional (sc (sc-name (tn-sc dst))))
+ (let ((val (tn-value constant-tn)))
+ (etypecase val
+ (integer
+ (if (memq sc '(any-reg descriptor-reg))
+ (inst mov dst (fixnumize val))
+ (inst mov dst val)))
+ (symbol
+ (aver (eq sc 'descriptor-reg))
+ (load-symbol dst val))
+ (character
+ (if (eq sc 'descriptor-reg)
+ (inst mov dst (logior (ash (char-code val) n-widetag-bits)
+ character-widetag))
+ (inst mov dst (char-code val))))))))
+ (cond ((null (rest flags))
+ (if (sc-is else immediate)
+ (load-immediate res else)
+ (move res else))
+ (when (sc-is then immediate)
+ (load-immediate temp-reg-tn then (sc-name (tn-sc res)))
+ (setf then temp-reg-tn))
+ (inst cmov (if not-p
+ (negate-condition (first flags))
+ (first flags))
+ res
+ then))
+ (not-p
+ (cond ((sc-is then immediate)
+ (when (location= else res)
+ (inst mov temp-reg-tn else)
+ (setf else temp-reg-tn))
+ (load-immediate res then))
+ ((location= else res)
+ (inst xchg else then)
+ (rotatef else then))
+ (t
+ (move res then)))
+ (when (sc-is else immediate)
+ (load-immediate temp-reg-tn else (sc-name (tn-sc res)))
+ (setf else temp-reg-tn))
+ (dolist (flag flags)
+ (inst cmov flag res else)))
+ (t
+ (if (sc-is else immediate)
+ (load-immediate res else)
+ (move res else))
+ (when (sc-is then immediate)
+ (load-immediate temp-reg-tn then (sc-name (tn-sc res)))
+ (setf then temp-reg-tn))
+ (dolist (flag flags)
+ (inst cmov flag res then))))))))
+
+(macrolet ((def-move-if (name type reg stack)
+ `(define-vop (,name move-if)
+ (:args (then :scs (immediate ,reg ,stack) :to :eval
+ :load-if (not (or (sc-is then immediate)
+ (and (sc-is then ,stack)
+ (not (location= else res))))))
+ (else :scs (immediate ,reg ,stack) :target res
+ :load-if (not (sc-is else immediate ,stack))))
+ (:arg-types ,type ,type)
+ (:results (res :scs (,reg)
+ :from (:argument 1)))
+ (:result-types ,type))))
+ (def-move-if move-if/t t descriptor-reg control-stack)
+ (def-move-if move-if/fx tagged-num any-reg control-stack)
+ (def-move-if move-if/unsigned unsigned-num unsigned-reg unsigned-stack)
+ (def-move-if move-if/signed signed-num signed-reg signed-stack)
+ ;; FIXME: See *CMOV-PTYPE-REPRESENTATION-VOP* above.
+ #!+sb-unicode
+ (def-move-if move-if/char character character-reg character-stack)
+ (def-move-if move-if/sap system-area-pointer sap-reg sap-stack))
+\f
;;;; conditional VOPs
;;; Note: a constant-tn is allowed in CMP; it uses an EA displacement,
;;; not immediate data.
(define-vop (if-eq)
(:args (x :scs (any-reg descriptor-reg control-stack constant)
- :load-if (not (and (sc-is x immediate)
- (sc-is y any-reg descriptor-reg
- control-stack constant))))
- (y :scs (any-reg descriptor-reg immediate)
- :load-if (not (and (sc-is x any-reg descriptor-reg immediate)
- (sc-is y control-stack constant)))))
- (:conditional)
- (:info target not-p)
+ :load-if (not (and (sc-is x immediate)
+ (sc-is y any-reg descriptor-reg
+ control-stack constant))))
+ (y :scs (any-reg descriptor-reg immediate)
+ :load-if (not (and (sc-is x any-reg descriptor-reg immediate)
+ (sc-is y control-stack constant)))))
+ (:temporary (:sc descriptor-reg) temp)
+ (:conditional :e)
(:policy :fast-safe)
(:translate eq)
- (:generator 3
+ (:generator 8
(cond
((sc-is y immediate)
(let ((val (tn-value y)))
- (etypecase val
- (integer
- (if (and (zerop val) (sc-is x any-reg descriptor-reg))
- (inst test x x) ; smaller
- (inst cmp x (fixnumize val))))
- (symbol
- (inst cmp x (+ nil-value (static-symbol-offset val))))
- (character
- (inst cmp x (logior (ash (char-code val) n-widetag-bits)
- base-char-widetag))))))
+ (etypecase val
+ (integer
+ (if (and (zerop val) (sc-is x any-reg descriptor-reg))
+ (inst test x x) ; smaller
+ (let ((fixnumized (fixnumize val)))
+ (if (typep fixnumized
+ '(or (signed-byte 32) (unsigned-byte 31)))
+ (inst cmp x fixnumized)
+ (progn
+ (inst mov temp fixnumized)
+ (inst cmp x temp))))))
+ (symbol
+ (inst cmp x (+ nil-value (static-symbol-offset val))))
+ (character
+ (inst cmp x (logior (ash (char-code val) n-widetag-bits)
+ character-widetag))))))
((sc-is x immediate) ; and y not immediate
;; Swap the order to fit the compare instruction.
(let ((val (tn-value x)))
- (etypecase val
- (integer
- (if (and (zerop val) (sc-is y any-reg descriptor-reg))
- (inst test y y) ; smaller
- (inst cmp y (fixnumize val))))
- (symbol
- (inst cmp y (+ nil-value (static-symbol-offset val))))
- (character
- (inst cmp y (logior (ash (char-code val) n-widetag-bits)
- base-char-widetag))))))
+ (etypecase val
+ (integer
+ (if (and (zerop val) (sc-is y any-reg descriptor-reg))
+ (inst test y y) ; smaller
+ (let ((fixnumized (fixnumize val)))
+ (if (typep fixnumized
+ '(or (signed-byte 32) (unsigned-byte 31)))
+ (inst cmp y fixnumized)
+ (progn
+ (inst mov temp fixnumized)
+ (inst cmp y temp))))))
+ (symbol
+ (inst cmp y (+ nil-value (static-symbol-offset val))))
+ (character
+ (inst cmp y (logior (ash (char-code val) n-widetag-bits)
+ character-widetag))))))
(t
- (inst cmp x y)))
+ (inst cmp x y)))))
- (inst jmp (if not-p :ne :e) target)))
+;; The template above is a very good fallback for the generic
+;; case. However, it is sometimes possible to perform unboxed
+;; comparisons. Repurpose char= and eql templates here, instead
+;; of forcing values to be boxed and then compared.
+;;
+;; We only weaken EQL => EQ for characters and fixnums, and detect
+;; when types definitely mismatch. No need to import other EQL
+;; VOPs (e.g. floats).
+(macrolet ((def (eq-name eql-name)
+ `(define-vop (,eq-name ,eql-name)
+ (:translate eq))))
+ (def fast-if-eq-character fast-char=/character)
+ (def fast-if-eq-character/c fast-char=/character/c)
+ (def fast-if-eq-fixnum fast-eql/fixnum)
+ (def fast-if-eq-fixnum/x fast-eql-c/fixnum)
+ (def fast-if-eq/signed fast-if-eql/signed)
+ (def fast-if-eq-c/signed fast-if-eql-c/signed)
+ (def fast-if-eq/unsigned fast-if-eql/unsigned)
+ (def fast-if-eq-c/unsigned fast-if-eql-c/unsigned))
projects / sbcl.git / blobdiff