1 ;;;; predicate VOPs for the x86 VM
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
16 ;;; The unconditional branch, emitted when we can't drop through to the desired
17 ;;; destination. Dest is the continuation we transfer control to.
24 ;;;; Generic conditional VOPs
26 ;;; The generic conditional branch, emitted immediately after test
27 ;;; VOPs that only set flags.
29 ;;; FLAGS is a list of condition descriptors. If the first descriptor
30 ;;; is CL:NOT, the test was true if all the remaining conditions are
31 ;;; false. Otherwise, the test was true if any of the conditions is.
33 ;;; NOT-P flips the meaning of the test, as with regular :CONDITIONAL
34 ;;; VOP. If NOT-P is true, the code must branch to dest if the test was
35 ;;; false. Otherwise, the code must branch to dest if the test was true.
37 (define-vop (branch-if)
38 (:info dest flags not-p)
40 (flet ((negate-condition (name)
41 (let ((code (logxor 1 (conditional-opcode name))))
42 (aref *condition-name-vec* code))))
43 (aver (null (rest flags)))
46 (negate-condition (first flags))
50 (defvar *cmov-ptype-representation-vop*
51 (mapcan (lambda (entry)
52 (destructuring-bind (ptypes &optional sc vop)
54 (unless (listp ptypes)
55 (setf ptypes (list ptypes)))
56 (mapcar (if (and vop sc)
61 '((t descriptor-reg move-if/t)
63 ((fixnum positive-fixnum)
65 ((unsigned-byte-32 unsigned-byte-31)
66 unsigned-reg move-if/unsigned)
67 (signed-byte-32 signed-reg move-if/signed)
68 (character character-reg move-if/char)
70 ((single-float complex-single-float
71 double-float complex-double-float))
73 (system-area-pointer sap-reg move-if/sap)))
74 "Alist of primitive type -> (storage-class-name VOP-name)
75 if values of such a type should be cmoved, and NIL otherwise.
77 storage-class-name is the name of the storage class to use for
78 the values, and VOP-name the name of the VOP that will be used
79 to execute the conditional move.")
81 (!def-vm-support-routine
82 convert-conditional-move-p (node dst-tn x-tn y-tn)
83 (declare (ignore node))
84 (let* ((ptype (sb!c::tn-primitive-type dst-tn))
85 (name (sb!c::primitive-type-name ptype))
86 (param (and (memq :cmov *backend-subfeatures*)
87 (cdr (or (assoc name *cmov-ptype-representation-vop*)
88 '(t descriptor-reg move-if/t))))))
90 (destructuring-bind (representation vop) param
91 (let ((scn (sc-number-or-lose representation)))
93 (make-representation-tn ptype scn))
95 (and (eq (sb!c::tn-kind tn) :constant)
96 (eq (sb!c::immediate-constant-sc (tn-value tn))
97 (sc-number-or-lose 'immediate))))
99 (if (immediate-tn-p tn)
103 (frob-tn x-tn) (frob-tn y-tn)
107 (define-vop (move-if)
108 (:args (then) (else))
109 (:temporary (:sc unsigned-reg :from :eval) temp)
113 (flet ((load-immediate (dst constant-tn
114 &optional (sc (sc-name (tn-sc dst))))
115 (let ((val (tn-value constant-tn)))
118 (if (memq sc '(any-reg descriptor-reg))
119 (inst mov dst (fixnumize val))
122 (aver (eq sc 'descriptor-reg))
123 (load-symbol dst val))
125 (cond ((memq sc '(any-reg descriptor-reg))
127 (logior (ash (char-code val) n-widetag-bits)
130 (aver (eq sc 'character-reg))
131 (inst mov dst (char-code val)))))))))
132 (aver (null (rest flags)))
133 (if (sc-is else immediate)
134 (load-immediate res else)
136 (when (sc-is then immediate)
137 (load-immediate temp then (sc-name (tn-sc res)))
139 (inst cmov (first flags) res then))))
141 (macrolet ((def-move-if (name type reg &optional stack)
142 (when stack (setf stack (list stack)))
144 `(define-vop (,name move-if)
145 (:args (then :scs (immediate ,reg ,@stack) :to :eval
147 :load-if (not (or (sc-is then immediate)
148 (and (sc-is then ,@stack)
149 (not (location= else res))))))
150 (else :scs (immediate ,reg ,@stack) :target res
151 :load-if (not (sc-is else immediate ,@stack))))
152 (:arg-types ,type ,type)
153 (:results (res :scs (,reg)
154 :from (:argument 1)))
155 (:result-types ,type))))
156 (def-move-if move-if/t
157 t descriptor-reg control-stack)
158 (def-move-if move-if/fx
159 tagged-num any-reg control-stack)
160 (def-move-if move-if/unsigned
161 unsigned-num unsigned-reg unsigned-stack)
162 (def-move-if move-if/signed
163 signed-num signed-reg signed-stack)
164 (def-move-if move-if/char
165 character character-reg character-stack)
166 (def-move-if move-if/sap
167 system-area-pointer sap-reg sap-stack))
170 ;;;; conditional VOPs
172 ;;; Note: a constant-tn is allowed in CMP; it uses an EA displacement,
173 ;;; not immediate data.
175 (:args (x :scs (any-reg descriptor-reg control-stack constant)
176 :load-if (not (and (sc-is x immediate)
177 (sc-is y any-reg descriptor-reg
178 control-stack constant))))
179 (y :scs (any-reg descriptor-reg immediate)
180 :load-if (not (and (sc-is x any-reg descriptor-reg immediate)
181 (sc-is y control-stack constant)))))
187 (let ((x-val (encode-value-if-immediate x))
188 (y-val (encode-value-if-immediate y)))
190 ;; Shorter instruction sequences for these two cases.
191 ((and (eql 0 y-val) (sc-is x any-reg descriptor-reg)) (inst test x x))
192 ((and (eql 0 x-val) (sc-is y any-reg descriptor-reg)) (inst test y y))
194 ;; An encoded value (literal integer) has to be the second argument.
195 ((sc-is x immediate) (inst cmp y x-val))
197 (t (inst cmp x y-val))))))