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 (when (eq (car flags) 'not)
42 (setf not-p (not not-p)))
43 (flet ((negate-condition (name)
44 (let ((code (logxor 1 (conditional-opcode name))))
45 (aref *condition-name-vec* code))))
46 (cond ((null (rest flags))
49 (negate-condition (first flags))
53 (let ((not-lab (gen-label))
54 (last (car (last flags))))
55 (dolist (flag (butlast flags))
56 (inst jmp flag not-lab))
57 (inst jmp (negate-condition last) dest)
58 (emit-label not-lab)))
61 (inst jmp flag dest)))))))
63 (defvar *cmov-ptype-representation-vop*
64 (mapcan (lambda (entry)
65 (destructuring-bind (ptypes &optional sc vop)
67 (unless (listp ptypes)
68 (setf ptypes (list ptypes)))
69 (mapcar (if (and vop sc)
74 '((t descriptor-reg move-if/t)
76 ((fixnum positive-fixnum)
78 ((unsigned-byte-64 unsigned-byte-63)
79 unsigned-reg move-if/unsigned)
80 (signed-byte-64 signed-reg move-if/signed)
81 ;; FIXME: Can't use CMOV with byte registers, and characters live
82 ;; in such outside of unicode builds. A better solution then just
83 ;; disabling MOVE-IF/CHAR should be possible, though.
85 (character character-reg move-if/char)
87 ((single-float complex-single-float
88 double-float complex-double-float))
90 (system-area-pointer sap-reg move-if/sap)))
91 "Alist of primitive type -> (storage-class-name VOP-name)
92 if values of such a type should be cmoved, and NIL otherwise.
94 storage-class-name is the name of the storage class to use for
95 the values, and VOP-name the name of the VOP that will be used
96 to execute the conditional move.")
98 (defun convert-conditional-move-p (node dst-tn x-tn y-tn)
99 (declare (ignore node))
100 (let* ((ptype (sb!c::tn-primitive-type dst-tn))
101 (name (sb!c::primitive-type-name ptype))
102 (param (cdr (or (assoc name *cmov-ptype-representation-vop*)
103 '(t descriptor-reg move-if/t)))))
105 (destructuring-bind (representation vop) param
106 (let ((scn (sc-number-or-lose representation)))
108 (make-representation-tn ptype scn))
110 (if (immediate-tn-p tn)
114 (frob-tn x-tn) (frob-tn y-tn)
118 (define-vop (move-if)
119 (:args (then) (else))
123 (let ((not-p (eq (first flags) 'not)))
124 (when not-p (pop flags))
125 (flet ((negate-condition (name)
126 (let ((code (logxor 1 (conditional-opcode name))))
127 (aref *condition-name-vec* code)))
128 (load-immediate (dst constant-tn
129 &optional (sc (sc-name (tn-sc dst))))
130 (let ((val (tn-value constant-tn)))
133 (if (memq sc '(any-reg descriptor-reg))
134 (inst mov dst (fixnumize val))
137 (aver (eq sc 'descriptor-reg))
138 (load-symbol dst val))
140 (if (eq sc 'descriptor-reg)
141 (inst mov dst (logior (ash (char-code val) n-widetag-bits)
143 (inst mov dst (char-code val))))))))
144 (cond ((null (rest flags))
145 (if (sc-is else immediate)
146 (load-immediate res else)
148 (when (sc-is then immediate)
149 (load-immediate temp-reg-tn then (sc-name (tn-sc res)))
150 (setf then temp-reg-tn))
152 (negate-condition (first flags))
157 (cond ((sc-is then immediate)
158 (when (location= else res)
159 (inst mov temp-reg-tn else)
160 (setf else temp-reg-tn))
161 (load-immediate res then))
162 ((location= else res)
163 (inst xchg else then)
167 (when (sc-is else immediate)
168 (load-immediate temp-reg-tn else (sc-name (tn-sc res)))
169 (setf else temp-reg-tn))
171 (inst cmov flag res else)))
173 (if (sc-is else immediate)
174 (load-immediate res else)
176 (when (sc-is then immediate)
177 (load-immediate temp-reg-tn then (sc-name (tn-sc res)))
178 (setf then temp-reg-tn))
180 (inst cmov flag res then))))))))
182 (macrolet ((def-move-if (name type reg stack)
183 `(define-vop (,name move-if)
184 (:args (then :scs (immediate ,reg ,stack) :to :eval
185 :load-if (not (or (sc-is then immediate)
186 (and (sc-is then ,stack)
187 (not (location= else res))))))
188 (else :scs (immediate ,reg ,stack) :target res
189 :load-if (not (sc-is else immediate ,stack))))
190 (:arg-types ,type ,type)
191 (:results (res :scs (,reg)
192 :from (:argument 1)))
193 (:result-types ,type))))
194 (def-move-if move-if/t t descriptor-reg control-stack)
195 (def-move-if move-if/fx tagged-num any-reg control-stack)
196 (def-move-if move-if/unsigned unsigned-num unsigned-reg unsigned-stack)
197 (def-move-if move-if/signed signed-num signed-reg signed-stack)
198 ;; FIXME: See *CMOV-PTYPE-REPRESENTATION-VOP* above.
200 (def-move-if move-if/char character character-reg character-stack)
201 (def-move-if move-if/sap system-area-pointer sap-reg sap-stack))
203 ;;;; conditional VOPs
205 ;;; Note: a constant-tn is allowed in CMP; it uses an EA displacement,
206 ;;; not immediate data.
208 (:args (x :scs (any-reg descriptor-reg control-stack constant)
209 :load-if (not (and (sc-is x immediate)
210 (sc-is y any-reg descriptor-reg
211 control-stack constant))))
212 (y :scs (any-reg descriptor-reg immediate)
213 :load-if (not (and (sc-is x any-reg descriptor-reg immediate)
214 (sc-is y control-stack constant)))))
215 (:temporary (:sc descriptor-reg) temp)
222 (let ((val (tn-value y)))
225 (if (and (zerop val) (sc-is x any-reg descriptor-reg))
226 (inst test x x) ; smaller
227 (let ((fixnumized (fixnumize val)))
228 (if (typep fixnumized
229 '(or (signed-byte 32) (unsigned-byte 31)))
230 (inst cmp x fixnumized)
232 (inst mov temp fixnumized)
233 (inst cmp x temp))))))
235 (inst cmp x (+ nil-value (static-symbol-offset val))))
237 (inst cmp x (logior (ash (char-code val) n-widetag-bits)
238 character-widetag))))))
239 ((sc-is x immediate) ; and y not immediate
240 ;; Swap the order to fit the compare instruction.
241 (let ((val (tn-value x)))
244 (if (and (zerop val) (sc-is y any-reg descriptor-reg))
245 (inst test y y) ; smaller
246 (let ((fixnumized (fixnumize val)))
247 (if (typep fixnumized
248 '(or (signed-byte 32) (unsigned-byte 31)))
249 (inst cmp y fixnumized)
251 (inst mov temp fixnumized)
252 (inst cmp y temp))))))
254 (inst cmp y (+ nil-value (static-symbol-offset val))))
256 (inst cmp y (logior (ash (char-code val) n-widetag-bits)
257 character-widetag))))))
261 ;; The template above is a very good fallback for the generic
262 ;; case. However, it is sometimes possible to perform unboxed
263 ;; comparisons. Repurpose char= and eql templates here, instead
264 ;; of forcing values to be boxed and then compared.
266 ;; We only weaken EQL => EQ for characters and fixnums, and detect
267 ;; when types definitely mismatch. No need to import other EQL
268 ;; VOPs (e.g. floats).
269 (macrolet ((def (eq-name eql-name cost)
270 `(define-vop (,eq-name ,eql-name)
272 (:variant-cost ,cost))))
273 (def fast-if-eq-character fast-char=/character 3)
274 (def fast-if-eq-character/c fast-char=/character/c 2)
275 (def fast-if-eq-fixnum fast-eql/fixnum 3)
276 (def fast-if-eq-fixnum/c fast-eql-c/fixnum 2)
277 (def fast-if-eq-signed fast-if-eql/signed 5)
278 (def fast-if-eq-signed/c fast-if-eql-c/signed 4)
279 (def fast-if-eq-unsigned fast-if-eql/unsigned 5)
280 (def fast-if-eq-unsigned/c fast-if-eql-c/unsigned 4))