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 (mapcar (if (and vop sc
)
58 (ensure-list ptypes
))))
59 '((t descriptor-reg move-if
/t
)
61 ((fixnum positive-fixnum
)
63 ((unsigned-byte-32 unsigned-byte-31
)
64 unsigned-reg move-if
/unsigned
)
65 (signed-byte-32 signed-reg move-if
/signed
)
66 ;; FIXME: Can't use CMOV with byte registers, and characters live
67 ;; in such outside of unicode builds. A better solution then just
68 ;; disabling MOVE-IF/CHAR should be possible, though.
70 (character character-reg move-if
/char
)
72 ((single-float complex-single-float
73 double-float complex-double-float
))
75 (system-area-pointer sap-reg move-if
/sap
)))
76 "Alist of primitive type -> (storage-class-name VOP-name)
77 if values of such a type should be cmoved, and NIL otherwise.
79 storage-class-name is the name of the storage class to use for
80 the values, and VOP-name the name of the VOP that will be used
81 to execute the conditional move.")
83 (defun convert-conditional-move-p (node dst-tn x-tn y-tn
)
84 (declare (ignore node
))
85 (let* ((ptype (sb!c
::tn-primitive-type dst-tn
))
86 (name (sb!c
::primitive-type-name ptype
))
87 (param (and (memq :cmov
*backend-subfeatures
*)
88 (cdr (or (assoc name
*cmov-ptype-representation-vop
*)
89 '(t descriptor-reg move-if
/t
))))))
91 (destructuring-bind (representation vop
) param
92 (let ((scn (sc-number-or-lose representation
)))
94 (make-representation-tn ptype scn
))
96 (if (immediate-tn-p tn
)
100 (frob-tn x-tn
) (frob-tn y-tn
)
104 (define-vop (move-if)
105 (:args
(then) (else))
106 (:temporary
(:sc unsigned-reg
:from
:eval
) temp
)
110 (flet ((load-immediate (dst constant-tn
111 &optional
(sc (sc-name (tn-sc dst
))))
112 (let ((val (tn-value constant-tn
)))
115 (if (memq sc
'(any-reg descriptor-reg
))
116 (inst mov dst
(fixnumize val
))
119 (aver (eq sc
'descriptor-reg
))
120 (load-symbol dst val
))
122 (cond ((memq sc
'(any-reg descriptor-reg
))
124 (logior (ash (char-code val
) n-widetag-bits
)
127 (aver (eq sc
'character-reg
))
128 (inst mov dst
(char-code val
)))))))))
129 (aver (null (rest flags
)))
130 (if (sc-is else immediate
)
131 (load-immediate res else
)
133 (when (sc-is then immediate
)
134 (load-immediate temp then
(sc-name (tn-sc res
)))
136 (inst cmov
(first flags
) res then
))))
138 (macrolet ((def-move-if (name type reg stack
)
139 `(define-vop (,name move-if
)
140 (:args
(then :scs
(immediate ,reg
,stack
) :to
:eval
142 :load-if
(not (or (sc-is then immediate
)
143 (and (sc-is then
,stack
)
144 (not (location= else res
))))))
145 (else :scs
(immediate ,reg
,stack
) :target res
146 :load-if
(not (sc-is else immediate
,stack
))))
147 (:arg-types
,type
,type
)
148 (:results
(res :scs
(,reg
)
149 :from
(:argument
1)))
150 (:result-types
,type
))))
151 (def-move-if move-if
/t t descriptor-reg control-stack
)
152 (def-move-if move-if
/fx tagged-num any-reg control-stack
)
153 (def-move-if move-if
/unsigned unsigned-num unsigned-reg unsigned-stack
)
154 (def-move-if move-if
/signed signed-num signed-reg signed-stack
)
155 ;; FIXME: See *CMOV-PTYPE-REPRESENTATION-VOP* above.
157 (def-move-if move-if
/char character character-reg character-stack
)
158 (def-move-if move-if
/sap system-area-pointer sap-reg sap-stack
))
161 ;;;; conditional VOPs
163 ;;; Note: a constant-tn is allowed in CMP; it uses an EA displacement,
164 ;;; not immediate data.
166 (:args
(x :scs
(any-reg descriptor-reg control-stack constant
)
167 :load-if
(not (and (sc-is x immediate
)
168 (sc-is y any-reg descriptor-reg
169 control-stack constant
))))
170 (y :scs
(any-reg descriptor-reg immediate
)
171 :load-if
(not (and (sc-is x any-reg descriptor-reg immediate
)
172 (sc-is y control-stack constant
)))))
178 (let ((x-val (encode-value-if-immediate x
))
179 (y-val (encode-value-if-immediate y
)))
181 ;; Shorter instruction sequences for these two cases.
182 ((and (eql 0 y-val
) (sc-is x any-reg descriptor-reg
)) (inst test x x
))
183 ((and (eql 0 x-val
) (sc-is y any-reg descriptor-reg
)) (inst test y y
))
185 ;; An encoded value (literal integer) has to be the second argument.
186 ((sc-is x immediate
) (inst cmp y x-val
))
188 (t (inst cmp x y-val
))))))
190 (macrolet ((def (eq-name eql-name cost
)
191 `(define-vop (,eq-name
,eql-name
)
193 (:variant-cost
,cost
))))
194 (def fast-if-eq-character fast-char
=/character
3)
195 (def fast-if-eq-character
/c fast-char
=/character
/c
2)
196 (def fast-if-eq-fixnum fast-eql
/fixnum
3)
197 (def fast-if-eq-fixnum
/c fast-eql-c
/fixnum
2)
198 (def fast-if-eq-signed fast-if-eql
/signed
5)
199 (def fast-if-eq-signed
/c fast-if-eql-c
/signed
4)
200 (def fast-if-eq-unsigned fast-if-eql
/unsigned
5)
201 (def fast-if-eq-unsigned
/c fast-if-eql-c
/unsigned
4))