X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86%2Fpred.lisp;h=7be691e9e2414da7895535c7701f02a5ab557d16;hb=09f925d42d072d74c6977cc52e3ebf36135d2e15;hp=e756b3b37a6f9b893b77edc8c27eb1d551070aa5;hpb=5cf3c4259d529e180d75d4d140f344e600d2b06b;p=sbcl.git diff --git a/src/compiler/x86/pred.lisp b/src/compiler/x86/pred.lisp index e756b3b..7be691e 100644 --- a/src/compiler/x86/pred.lisp +++ b/src/compiler/x86/pred.lisp @@ -25,17 +25,140 @@ ;;; 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) - (:ignore dest flags not-p) (:generator 0 - (error "BRANCH-IF not yet implemented"))) + (flet ((negate-condition (name) + (let ((code (logxor 1 (conditional-opcode name)))) + (aref *condition-name-vec* code)))) + (aver (null (rest flags))) + (inst jmp + (if not-p + (negate-condition (first flags)) + (first flags)) + 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-32 unsigned-byte-31) + unsigned-reg move-if/unsigned) + (signed-byte-32 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 dst-tn x-tn y-tn)) - nil) + (declare (ignore node)) + (let* ((ptype (sb!c::tn-primitive-type dst-tn)) + (name (sb!c::primitive-type-name ptype)) + (param (and (memq :cmov *backend-subfeatures*) + (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)) + (:temporary (:sc unsigned-reg :from :eval) temp) + (:results (res)) + (:info flags) + (:generator 0 + (flet ((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 + (cond ((memq sc '(any-reg descriptor-reg)) + (inst mov dst + (logior (ash (char-code val) n-widetag-bits) + character-widetag))) + (t + (aver (eq sc 'character-reg)) + (inst mov dst (char-code val))))))))) + (aver (null (rest flags))) + (if (sc-is else immediate) + (load-immediate res else) + (move res else)) + (when (sc-is then immediate) + (load-immediate temp then (sc-name (tn-sc res))) + (setf then temp)) + (inst cmov (first flags) res then)))) + +(macrolet ((def-move-if (name type reg stack) + `(define-vop (,name move-if) + (:args (then :scs (immediate ,reg ,stack) :to :eval + :target temp + :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)) ;;;; conditional VOPs @@ -50,11 +173,11 @@ (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) + (:conditional :e) + (:info) (:policy :fast-safe) (:translate eq) - (:generator 3 + (:generator 8 (let ((x-val (encode-value-if-immediate x)) (y-val (encode-value-if-immediate y))) (cond @@ -65,6 +188,14 @@ ;; An encoded value (literal integer) has to be the second argument. ((sc-is x immediate) (inst cmp y x-val)) - (t (inst cmp x y-val)))) + (t (inst cmp x y-val)))))) - (inst jmp (if not-p :ne :e) target))) +(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/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))