1 ;;;; the x86 VM definition of operand loading/saving and the MOVE vop
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.
14 (define-move-fun (load-immediate 1) (vop x y)
16 (any-reg descriptor-reg))
17 (let ((val (tn-value x)))
22 (inst mov y (fixnumize val))))
26 (inst mov y (logior (ash (char-code val) n-widetag-bits)
27 base-char-widetag))))))
29 (define-move-fun (load-number 1) (vop x y)
30 ((immediate) (signed-reg unsigned-reg))
31 (inst mov y (tn-value x)))
33 (define-move-fun (load-base-char 1) (vop x y)
34 ((immediate) (base-char-reg))
35 (inst mov y (char-code (tn-value x))))
37 (define-move-fun (load-system-area-pointer 1) (vop x y)
38 ((immediate) (sap-reg))
39 (inst mov y (sap-int (tn-value x))))
41 (define-move-fun (load-constant 5) (vop x y)
42 ((constant) (descriptor-reg any-reg))
45 (define-move-fun (load-stack 5) (vop x y)
46 ((control-stack) (any-reg descriptor-reg)
47 (base-char-stack) (base-char-reg)
49 (signed-stack) (signed-reg)
50 (unsigned-stack) (unsigned-reg))
53 (define-move-fun (store-stack 5) (vop x y)
54 ((any-reg descriptor-reg) (control-stack)
55 (base-char-reg) (base-char-stack)
57 (signed-reg) (signed-stack)
58 (unsigned-reg) (unsigned-stack))
63 (:args (x :scs (any-reg descriptor-reg immediate) :target y
64 :load-if (not (location= x y))))
65 (:results (y :scs (any-reg descriptor-reg)
67 (not (or (location= x y)
68 (and (sc-is x any-reg descriptor-reg immediate)
69 (sc-is y control-stack))))))
73 (if (and (sc-is x immediate)
74 (sc-is y any-reg descriptor-reg control-stack))
75 (let ((val (tn-value x)))
78 (if (and (zerop val) (sc-is y any-reg descriptor-reg))
80 (multiple-value-bind (lo hi) (dwords-for-quad (fixnumize val))
88 (inst mov y (+ nil-value (static-symbol-offset val))))
90 (inst mov y (logior (ash (char-code val) n-widetag-bits)
91 base-char-widetag)))))
94 (define-move-vop move :move
95 (any-reg descriptor-reg immediate)
96 (any-reg descriptor-reg))
98 ;;; Make MOVE the check VOP for T so that type check generation
99 ;;; doesn't think it is a hairy type. This also allows checking of a
100 ;;; few of the values in a continuation to fall out.
101 (primitive-type-vop move (:check) t)
103 ;;; The MOVE-ARG VOP is used for moving descriptor values into
104 ;;; another frame for argument or known value passing.
106 ;;; Note: It is not going to be possible to move a constant directly
107 ;;; to another frame, except if the destination is a register and in
108 ;;; this case the loading works out.
109 (define-vop (move-arg)
110 (:args (x :scs (any-reg descriptor-reg immediate) :target y
111 :load-if (not (and (sc-is y any-reg descriptor-reg)
112 (sc-is x control-stack))))
114 :load-if (not (sc-is y any-reg descriptor-reg))))
118 ((any-reg descriptor-reg)
119 (if (sc-is x immediate)
120 (let ((val (tn-value x)))
124 ((or (signed-byte 29) (unsigned-byte 29))
125 (inst mov y (fixnumize val)))
127 (multiple-value-bind (lo hi)
128 (dwords-for-quad (fixnumize val))
135 (inst mov y (logior (ash (char-code val) n-widetag-bits)
136 base-char-widetag)))))
139 (if (sc-is x immediate)
140 (let ((val (tn-value x)))
141 (if (= (tn-offset fp) esp-offset)
145 (storew (fixnumize val) fp (tn-offset y)))
147 (storew (+ nil-value (static-symbol-offset val))
150 (storew (logior (ash (char-code val) n-widetag-bits)
156 (storew (fixnumize val) fp (- (1+ (tn-offset y)))))
158 (storew (+ nil-value (static-symbol-offset val))
159 fp (- (1+ (tn-offset y)))))
161 (storew (logior (ash (char-code val) n-widetag-bits)
163 fp (- (1+ (tn-offset y))))))))
164 (if (= (tn-offset fp) esp-offset)
166 (storew x fp (tn-offset y))
168 (storew x fp (- (1+ (tn-offset y))))))))))
170 (define-move-vop move-arg :move-arg
171 (any-reg descriptor-reg)
172 (any-reg descriptor-reg))
176 ;;; This VOP exists just to begin the lifetime of a TN that couldn't
177 ;;; be written legally due to a type error. An error is signalled
178 ;;; before this VOP is so we don't need to do anything (not that there
179 ;;; would be anything sensible to do anyway.)
180 (define-vop (illegal-move)
185 (:save-p :compute-only)
187 (error-call vop object-not-type-error x type)))
189 ;;;; moves and coercions
191 ;;; These MOVE-TO-WORD VOPs move a tagged integer to a raw full-word
192 ;;; representation. Similarly, the MOVE-FROM-WORD VOPs converts a raw
193 ;;; integer to a tagged bignum or fixnum.
195 ;;; Arg is a fixnum, so just shift it. We need a type restriction
196 ;;; because some possible arg SCs (control-stack) overlap with
197 ;;; possible bignum arg SCs.
198 (define-vop (move-to-word/fixnum)
199 (:args (x :scs (any-reg descriptor-reg) :target y
200 :load-if (not (location= x y))))
201 (:results (y :scs (signed-reg unsigned-reg)
202 :load-if (not (location= x y))))
203 (:arg-types tagged-num)
204 (:note "fixnum untagging")
207 (inst sar y (1- n-lowtag-bits))))
208 (define-move-vop move-to-word/fixnum :move
209 (any-reg descriptor-reg) (signed-reg unsigned-reg))
211 ;;; Arg is a non-immediate constant, load it.
212 (define-vop (move-to-word-c)
213 (:args (x :scs (constant)))
214 (:results (y :scs (signed-reg unsigned-reg)))
215 (:note "constant load")
217 (inst mov y (tn-value x))))
218 (define-move-vop move-to-word-c :move
219 (constant) (signed-reg unsigned-reg))
222 ;;; Arg is a fixnum or bignum, figure out which and load if necessary.
223 (define-vop (move-to-word/integer)
224 (:args (x :scs (descriptor-reg) :target eax))
225 (:results (y :scs (signed-reg unsigned-reg)))
226 (:note "integer to untagged word coercion")
227 (:temporary (:sc unsigned-reg :offset eax-offset
228 :from (:argument 0) :to (:result 0) :target y) eax)
231 (inst test al-tn 7) ; a symbolic constant for this
232 (inst jmp :z fixnum) ; would be nice
233 (loadw y eax bignum-digits-offset other-pointer-lowtag)
236 (inst sar eax (1- n-lowtag-bits))
239 (define-move-vop move-to-word/integer :move
240 (descriptor-reg) (signed-reg unsigned-reg))
243 ;;; Result is a fixnum, so we can just shift. We need the result type
244 ;;; restriction because of the control-stack ambiguity noted above.
245 (define-vop (move-from-word/fixnum)
246 (:args (x :scs (signed-reg unsigned-reg) :target y
247 :load-if (not (location= x y))))
248 (:results (y :scs (any-reg descriptor-reg)
249 :load-if (not (location= x y))))
250 (:result-types tagged-num)
251 (:note "fixnum tagging")
253 (cond ((and (sc-is x signed-reg unsigned-reg)
254 (not (location= x y)))
255 ;; Uses 7 bytes, but faster on the Pentium
256 (inst lea y (make-ea :qword :index x :scale 8)))
258 ;; Uses: If x is a reg 2 + 3; if x = y uses only 3 bytes
260 (inst shl y (1- n-lowtag-bits))))))
261 (define-move-vop move-from-word/fixnum :move
262 (signed-reg unsigned-reg) (any-reg descriptor-reg))
264 ;;; Result may be a bignum, so we have to check. Use a worst-case cost
265 ;;; to make sure people know they may be number consing.
267 ;;; KLUDGE: I assume this is suppressed in favor of the "faster inline
268 ;;; version" below. (See also mysterious comment "we don't want a VOP
269 ;;; on this one" on DEFINE-ASSEMBLY-ROUTINE (MOVE-FROM-SIGNED) in
270 ;;; "src/assembly/x86/alloc.lisp".) -- WHN 19990916
272 (define-vop (move-from-signed)
273 (:args (x :scs (signed-reg unsigned-reg) :target eax))
274 (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)) eax)
275 (:temporary (:sc unsigned-reg :offset ebx-offset :to (:result 0) :target y)
277 (:temporary (:sc unsigned-reg :offset ecx-offset
278 :from (:argument 0) :to (:result 0)) ecx)
280 (:results (y :scs (any-reg descriptor-reg)))
281 (:note "signed word to integer coercion")
284 (inst call (make-fixup 'move-from-signed :assembly-routine))
286 ;;; Faster inline version,
287 ;;; KLUDGE: Do we really want the faster inline version? It's sorta big.
288 ;;; It is nice that it doesn't use any temporaries, though. -- WHN 19990916
289 (define-vop (move-from-signed)
290 (:args (x :scs (signed-reg unsigned-reg) :to :result))
291 (:results (y :scs (any-reg descriptor-reg) :from :argument))
292 (:note "signed word to integer coercion")
295 (aver (not (location= x y)))
296 (let ((bignum (gen-label))
307 (assemble (*elsewhere*)
309 (with-fixed-allocation
310 (y bignum-widetag (+ bignum-digits-offset 1) node)
311 (storew x y bignum-digits-offset other-pointer-lowtag))
313 (define-move-vop move-from-signed :move
314 (signed-reg) (descriptor-reg))
316 ;;; Check for fixnum, and possibly allocate one or two word bignum
317 ;;; result. Use a worst-case cost to make sure people know they may be
320 (define-vop (move-from-unsigned)
321 (:args (x :scs (signed-reg unsigned-reg) :to :save))
322 (:temporary (:sc unsigned-reg) alloc)
323 (:results (y :scs (any-reg descriptor-reg)))
325 (:note "unsigned word to integer coercion")
327 (aver (not (location= x y)))
328 (aver (not (location= x alloc)))
329 (aver (not (location= y alloc)))
330 (let ((bignum (gen-label))
332 (one-word-bignum (gen-label))
334 (inst bsr y x) ;find msb
337 (inst jmp :ae bignum)
338 (inst lea y (make-ea :qword :index x :scale 8))
340 (assemble (*elsewhere*)
342 ;; Note: As on the mips port, space for a two word bignum is
343 ;; always allocated and the header size is set to either one
344 ;; or two words as appropriate.
345 (inst jmp :ns one-word-bignum)
347 (inst mov y (logior (ash (1- (+ bignum-digits-offset 2))
351 (emit-label one-word-bignum)
352 (inst mov y (logior (ash (1- (+ bignum-digits-offset 1))
357 (allocation alloc (pad-data-block (+ bignum-digits-offset 2)) node)
359 (inst lea y (make-ea :byte :base alloc :disp other-pointer-lowtag))
360 (storew x y bignum-digits-offset other-pointer-lowtag))
362 (define-move-vop move-from-unsigned :move
363 (unsigned-reg) (descriptor-reg))
365 ;;; Move untagged numbers.
366 (define-vop (word-move)
367 (:args (x :scs (signed-reg unsigned-reg) :target y
368 :load-if (not (location= x y))))
369 (:results (y :scs (signed-reg unsigned-reg)
371 (not (or (location= x y)
372 (and (sc-is x signed-reg unsigned-reg)
373 (sc-is y signed-stack unsigned-stack))))))
376 (:note "word integer move")
379 (define-move-vop word-move :move
380 (signed-reg unsigned-reg) (signed-reg unsigned-reg))
382 ;;; Move untagged number arguments/return-values.
383 (define-vop (move-word-arg)
384 (:args (x :scs (signed-reg unsigned-reg) :target y)
385 (fp :scs (any-reg) :load-if (not (sc-is y sap-reg))))
387 (:note "word integer argument move")
390 ((signed-reg unsigned-reg)
392 ((signed-stack unsigned-stack)
393 (if (= (tn-offset fp) esp-offset)
394 (storew x fp (tn-offset y)) ; c-call
395 (storew x fp (- (1+ (tn-offset y)))))))))
396 (define-move-vop move-word-arg :move-arg
397 (descriptor-reg any-reg signed-reg unsigned-reg) (signed-reg unsigned-reg))
399 ;;; Use standard MOVE-ARG and coercion to move an untagged number
400 ;;; to a descriptor passing location.
401 (define-move-vop move-arg :move-arg
402 (signed-reg unsigned-reg) (any-reg descriptor-reg))