[91ee7a]: src / compiler / x86-64 / pred.lisp Maximize Restore History

Download this file

pred.lisp    270 lines (249 with data), 10.8 kB

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
;;;; predicate VOPs for the x86 VM
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
(in-package "SB!VM")
;;;; the branch VOP
;;; The unconditional branch, emitted when we can't drop through to the desired
;;; destination. Dest is the continuation we transfer control to.
(define-vop (branch)
(:info dest)
(:generator 5
(inst jmp dest)))
;;;; Generic conditional VOPs
;;; 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)
(:generator 0
(when (eq (car flags) 'not)
(pop flags)
(setf not-p (not not-p)))
(flet ((negate-condition (name)
(let ((code (logxor 1 (conditional-opcode name))))
(aref *condition-name-vec* code))))
(cond ((null (rest flags))
(inst jmp
(if not-p
(negate-condition (first flags))
(first flags))
dest))
(not-p
(let ((not-lab (gen-label))
(last (car (last flags))))
(dolist (flag (butlast flags))
(inst jmp flag not-lab))
(inst jmp (negate-condition last) dest)
(emit-label not-lab)))
(t
(dolist (flag flags)
(inst jmp flag 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-64 unsigned-byte-63)
unsigned-reg move-if/unsigned)
(signed-byte-64 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))
(let* ((ptype (sb!c::tn-primitive-type dst-tn))
(name (sb!c::primitive-type-name ptype))
(param (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))
(:results (res))
(:info flags)
(:generator 0
(let ((not-p (eq (first flags) 'not)))
(when not-p (pop flags))
(flet ((negate-condition (name)
(let ((code (logxor 1 (conditional-opcode name))))
(aref *condition-name-vec* code)))
(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
(if (eq sc 'descriptor-reg)
(inst mov dst (logior (ash (char-code val) n-widetag-bits)
character-widetag))
(inst mov dst (char-code val))))))))
(cond ((null (rest flags))
(if (sc-is else immediate)
(load-immediate res else)
(move res else))
(when (sc-is then immediate)
(load-immediate temp-reg-tn then (sc-name (tn-sc res)))
(setf then temp-reg-tn))
(inst cmov (if not-p
(negate-condition (first flags))
(first flags))
res
then))
(not-p
(cond ((sc-is then immediate)
(when (location= else res)
(inst mov temp-reg-tn else)
(setf else temp-reg-tn))
(load-immediate res then))
((location= else res)
(inst xchg else then)
(rotatef else then))
(t
(move res then)))
(when (sc-is else immediate)
(load-immediate temp-reg-tn else (sc-name (tn-sc res)))
(setf else temp-reg-tn))
(dolist (flag flags)
(inst cmov flag res else)))
(t
(if (sc-is else immediate)
(load-immediate res else)
(move res else))
(when (sc-is then immediate)
(load-immediate temp-reg-tn then (sc-name (tn-sc res)))
(setf then temp-reg-tn))
(dolist (flag flags)
(inst cmov flag res then))))))))
(macrolet ((def-move-if (name type reg &optional stack)
(when stack (setf stack (list stack)))
`(define-vop (,name move-if)
(:args (then :scs (immediate ,reg ,@stack) :to :eval
: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
;;; Note: a constant-tn is allowed in CMP; it uses an EA displacement,
;;; not immediate data.
(define-vop (if-eq)
(:args (x :scs (any-reg descriptor-reg control-stack constant)
:load-if (not (and (sc-is x immediate)
(sc-is y any-reg descriptor-reg
control-stack constant))))
(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)))))
(:temporary (:sc descriptor-reg) temp)
(:conditional :e)
(:policy :fast-safe)
(:translate eq)
(:generator 3
(cond
((sc-is y immediate)
(let ((val (tn-value y)))
(etypecase val
(integer
(if (and (zerop val) (sc-is x any-reg descriptor-reg))
(inst test x x) ; smaller
(let ((fixnumized (fixnumize val)))
(if (typep fixnumized
'(or (signed-byte 32) (unsigned-byte 31)))
(inst cmp x fixnumized)
(progn
(inst mov temp fixnumized)
(inst cmp x temp))))))
(symbol
(inst cmp x (+ nil-value (static-symbol-offset val))))
(character
(inst cmp x (logior (ash (char-code val) n-widetag-bits)
character-widetag))))))
((sc-is x immediate) ; and y not immediate
;; Swap the order to fit the compare instruction.
(let ((val (tn-value x)))
(etypecase val
(integer
(if (and (zerop val) (sc-is y any-reg descriptor-reg))
(inst test y y) ; smaller
(let ((fixnumized (fixnumize val)))
(if (typep fixnumized
'(or (signed-byte 32) (unsigned-byte 31)))
(inst cmp y fixnumized)
(progn
(inst mov temp fixnumized)
(inst cmp y temp))))))
(symbol
(inst cmp y (+ nil-value (static-symbol-offset val))))
(character
(inst cmp y (logior (ash (char-code val) n-widetag-bits)
character-widetag))))))
(t
(inst cmp x y)))))