delete ye olde FIXME relating to unbound variable warnings
[sbcl.git] / src / compiler / x86-64 / pred.lisp
1 ;;;; predicate VOPs for the x86 VM
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
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.
11
12 (in-package "SB!VM")
13 \f
14 ;;;; the branch VOP
15
16 ;;; The unconditional branch, emitted when we can't drop through to the desired
17 ;;; destination. Dest is the continuation we transfer control to.
18 (define-vop (branch)
19   (:info dest)
20   (:generator 5
21     (inst jmp dest)))
22
23 \f
24 ;;;; Generic conditional VOPs
25
26 ;;; The generic conditional branch, emitted immediately after test
27 ;;; VOPs that only set flags.
28 ;;;
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.
32 ;;;
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.
36
37 (define-vop (branch-if)
38   (:info dest flags not-p)
39   (:generator 0
40      (when (eq (car flags) 'not)
41        (pop flags)
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))
47               (inst jmp
48                     (if not-p
49                         (negate-condition (first flags))
50                         (first flags))
51                     dest))
52              (not-p
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)))
59              (t
60               (dolist (flag flags)
61                 (inst jmp flag dest)))))))
62
63 (defvar *cmov-ptype-representation-vop*
64   (mapcan (lambda (entry)
65             (destructuring-bind (ptypes &optional sc vop)
66                 entry
67               (unless (listp ptypes)
68                 (setf ptypes (list ptypes)))
69               (mapcar (if (and vop sc)
70                           (lambda (ptype)
71                             (list ptype sc vop))
72                           #'list)
73                       ptypes)))
74           '((t descriptor-reg move-if/t)
75
76             ((fixnum positive-fixnum)
77              any-reg move-if/fx)
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.
84             #!+sb-unicode
85             (character character-reg move-if/char)
86
87             ((single-float complex-single-float
88               double-float complex-double-float))
89
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.
93
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.")
97
98 (!def-vm-support-routine
99     convert-conditional-move-p (node dst-tn x-tn y-tn)
100   (declare (ignore node))
101   (let* ((ptype (sb!c::tn-primitive-type dst-tn))
102          (name  (sb!c::primitive-type-name ptype))
103          (param (cdr (or (assoc name *cmov-ptype-representation-vop*)
104                          '(t descriptor-reg move-if/t)))))
105     (when param
106       (destructuring-bind (representation vop) param
107         (let ((scn (sc-number-or-lose representation)))
108           (labels ((make-tn ()
109                      (make-representation-tn ptype scn))
110                    (frob-tn (tn)
111                      (if (immediate-tn-p tn)
112                          tn
113                          (make-tn))))
114             (values vop
115                     (frob-tn x-tn) (frob-tn y-tn)
116                     (make-tn)
117                     nil)))))))
118
119 (define-vop (move-if)
120   (:args (then) (else))
121   (:results (res))
122   (:info flags)
123   (:generator 0
124      (let ((not-p (eq (first flags) 'not)))
125        (when not-p (pop flags))
126        (flet ((negate-condition (name)
127                 (let ((code (logxor 1 (conditional-opcode name))))
128                   (aref *condition-name-vec* code)))
129               (load-immediate (dst constant-tn
130                                    &optional (sc (sc-name (tn-sc dst))))
131                 (let ((val (tn-value constant-tn)))
132                   (etypecase val
133                     (integer
134                        (if (memq sc '(any-reg descriptor-reg))
135                            (inst mov dst (fixnumize val))
136                            (inst mov dst val)))
137                     (symbol
138                        (aver (eq sc 'descriptor-reg))
139                        (load-symbol dst val))
140                     (character
141                        (if (eq sc 'descriptor-reg)
142                            (inst mov dst (logior (ash (char-code val) n-widetag-bits)
143                                                  character-widetag))
144                            (inst mov dst (char-code val))))))))
145          (cond ((null (rest flags))
146                 (if (sc-is else immediate)
147                     (load-immediate res else)
148                     (move res else))
149                 (when (sc-is then immediate)
150                   (load-immediate temp-reg-tn then (sc-name (tn-sc res)))
151                   (setf then temp-reg-tn))
152                 (inst cmov (if not-p
153                                (negate-condition (first flags))
154                                (first flags))
155                       res
156                       then))
157                (not-p
158                 (cond ((sc-is then immediate)
159                        (when (location= else res)
160                          (inst mov temp-reg-tn else)
161                          (setf else temp-reg-tn))
162                        (load-immediate res then))
163                       ((location= else res)
164                        (inst xchg else then)
165                        (rotatef else then))
166                       (t
167                        (move res then)))
168                 (when (sc-is else immediate)
169                   (load-immediate temp-reg-tn else (sc-name (tn-sc res)))
170                   (setf else temp-reg-tn))
171                 (dolist (flag flags)
172                   (inst cmov flag res else)))
173                (t
174                 (if (sc-is else immediate)
175                     (load-immediate res else)
176                     (move res else))
177                 (when (sc-is then immediate)
178                   (load-immediate temp-reg-tn then (sc-name (tn-sc res)))
179                   (setf then temp-reg-tn))
180                 (dolist (flag flags)
181                   (inst cmov flag res then))))))))
182
183 (macrolet ((def-move-if (name type reg stack)
184              `(define-vop (,name move-if)
185                 (:args (then :scs (immediate ,reg ,stack) :to :eval
186                              :load-if (not (or (sc-is then immediate)
187                                                (and (sc-is then ,stack)
188                                                     (not (location= else res))))))
189                        (else :scs (immediate ,reg ,stack) :target res
190                              :load-if (not (sc-is else immediate ,stack))))
191                 (:arg-types ,type ,type)
192                 (:results (res :scs (,reg)
193                                :from (:argument 1)))
194                 (:result-types ,type))))
195   (def-move-if move-if/t t descriptor-reg control-stack)
196   (def-move-if move-if/fx tagged-num any-reg control-stack)
197   (def-move-if move-if/unsigned unsigned-num unsigned-reg unsigned-stack)
198   (def-move-if move-if/signed signed-num signed-reg signed-stack)
199   ;; FIXME: See *CMOV-PTYPE-REPRESENTATION-VOP* above.
200   #!+sb-unicode
201   (def-move-if move-if/char character character-reg character-stack)
202   (def-move-if move-if/sap system-area-pointer sap-reg sap-stack))
203 \f
204 ;;;; conditional VOPs
205
206 ;;; Note: a constant-tn is allowed in CMP; it uses an EA displacement,
207 ;;; not immediate data.
208 (define-vop (if-eq)
209   (:args (x :scs (any-reg descriptor-reg control-stack constant)
210             :load-if (not (and (sc-is x immediate)
211                                (sc-is y any-reg descriptor-reg
212                                       control-stack constant))))
213          (y :scs (any-reg descriptor-reg immediate)
214             :load-if (not (and (sc-is x any-reg descriptor-reg immediate)
215                                (sc-is y control-stack constant)))))
216   (:temporary (:sc descriptor-reg) temp)
217   (:conditional :e)
218   (:policy :fast-safe)
219   (:translate eq)
220   (:generator 8
221     (cond
222      ((sc-is y immediate)
223       (let ((val (tn-value y)))
224         (etypecase val
225           (integer
226            (if (and (zerop val) (sc-is x any-reg descriptor-reg))
227                (inst test x x) ; smaller
228              (let ((fixnumized (fixnumize val)))
229                (if (typep fixnumized
230                           '(or (signed-byte 32) (unsigned-byte 31)))
231                    (inst cmp x fixnumized)
232                  (progn
233                    (inst mov temp fixnumized)
234                    (inst cmp x temp))))))
235           (symbol
236            (inst cmp x (+ nil-value (static-symbol-offset val))))
237           (character
238            (inst cmp x (logior (ash (char-code val) n-widetag-bits)
239                                character-widetag))))))
240      ((sc-is x immediate) ; and y not immediate
241       ;; Swap the order to fit the compare instruction.
242       (let ((val (tn-value x)))
243         (etypecase val
244           (integer
245            (if (and (zerop val) (sc-is y any-reg descriptor-reg))
246                (inst test y y) ; smaller
247              (let ((fixnumized (fixnumize val)))
248                (if (typep fixnumized
249                           '(or (signed-byte 32) (unsigned-byte 31)))
250                    (inst cmp y fixnumized)
251                  (progn
252                    (inst mov temp fixnumized)
253                    (inst cmp y temp))))))
254           (symbol
255            (inst cmp y (+ nil-value (static-symbol-offset val))))
256           (character
257            (inst cmp y (logior (ash (char-code val) n-widetag-bits)
258                                character-widetag))))))
259       (t
260        (inst cmp x y)))))
261
262 ;; The template above is a very good fallback for the generic
263 ;; case.  However, it is sometimes possible to perform unboxed
264 ;; comparisons.  Repurpose char= and eql templates here, instead
265 ;; of forcing values to be boxed and then compared.
266 ;;
267 ;; We only weaken EQL => EQ for characters and fixnums, and detect
268 ;; when types definitely mismatch.  No need to import other EQL
269 ;; VOPs (e.g. floats).
270 (macrolet ((def (eq-name eql-name)
271              `(define-vop (,eq-name ,eql-name)
272                 (:translate eq))))
273   (def fast-if-eq-character fast-char=/character)
274   (def fast-if-eq-character/c fast-char=/character/c)
275   (def fast-if-eq-fixnum fast-eql/fixnum)
276   (def fast-if-eq-fixnum/c fast-eql-c/fixnum)
277   (def fast-if-eq/signed fast-if-eql/signed)
278   (def fast-if-eq-c/signed fast-if-eql-c/signed)
279   (def fast-if-eq/unsigned fast-if-eql/unsigned)
280   (def fast-if-eq-c/unsigned fast-if-eql-c/unsigned))