1.0.1.4:
[sbcl.git] / src / compiler / x86-64 / move.lisp
1 ;;;; the x86-64 VM definition of operand loading/saving and the MOVE vop
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
14 (defun zeroize (tn)
15   (let ((offset (tn-offset tn)))
16     ;; Using the 32-bit instruction accomplishes the same thing and is
17     ;; one byte shorter.
18     (if (<= offset edi-offset)
19         (let ((tn (make-random-tn :kind :normal
20                                   :sc (sc-or-lose 'dword-reg)
21                                   :offset offset)))
22           (inst xor tn tn))
23         (inst xor tn tn))))
24
25 (define-move-fun (load-immediate 1) (vop x y)
26   ((immediate)
27    (any-reg descriptor-reg))
28   (let ((val (tn-value x)))
29     (etypecase val
30       (integer
31        (if (zerop val)
32            (zeroize y)
33          (inst mov y (fixnumize val))))
34       (symbol
35        (load-symbol y val))
36       (character
37        (inst mov y (logior (ash (char-code val) n-widetag-bits)
38                            character-widetag))))))
39
40 (define-move-fun (load-number 1) (vop x y)
41   ((immediate) (signed-reg unsigned-reg))
42   (let ((val (tn-value x)))
43     (if (zerop val)
44         (zeroize y)
45         (inst mov y val))))
46
47 (define-move-fun (load-character 1) (vop x y)
48   ((immediate) (character-reg))
49   (inst mov y (char-code (tn-value x))))
50
51 (define-move-fun (load-system-area-pointer 1) (vop x y)
52   ((immediate) (sap-reg))
53   (inst mov y (sap-int (tn-value x))))
54
55 (define-move-fun (load-constant 5) (vop x y)
56   ((constant) (descriptor-reg any-reg))
57   (inst mov y x))
58
59 (define-move-fun (load-stack 5) (vop x y)
60   ((control-stack) (any-reg descriptor-reg)
61    (character-stack) (character-reg)
62    (sap-stack) (sap-reg)
63    (signed-stack) (signed-reg)
64    (unsigned-stack) (unsigned-reg))
65   (inst mov y x))
66
67 (define-move-fun (store-stack 5) (vop x y)
68   ((any-reg descriptor-reg) (control-stack)
69    (character-reg) (character-stack)
70    (sap-reg) (sap-stack)
71    (signed-reg) (signed-stack)
72    (unsigned-reg) (unsigned-stack))
73   (inst mov y x))
74 \f
75 ;;;; the MOVE VOP
76 (define-vop (move)
77   (:args (x :scs (any-reg descriptor-reg immediate) :target y
78             :load-if (not (location= x y))))
79   (:results (y :scs (any-reg descriptor-reg)
80                :load-if
81                (not (or (location= x y)
82                         (and (sc-is x any-reg descriptor-reg immediate)
83                              (sc-is y control-stack))))))
84   (:temporary (:sc unsigned-reg) temp)
85   (:effects)
86   (:affected)
87   (:generator 0
88     (if (and (sc-is x immediate)
89              (sc-is y any-reg descriptor-reg control-stack))
90         (let ((val (tn-value x)))
91           (etypecase val
92             (integer
93              (if (and (zerop val) (sc-is y any-reg descriptor-reg))
94                  (zeroize y)
95                  (move-immediate y (fixnumize val) temp)))
96             (symbol
97              (inst mov y (+ nil-value (static-symbol-offset val))))
98             (character
99              (inst mov y (logior (ash (char-code val) n-widetag-bits)
100                                  character-widetag)))))
101         (move y x))))
102
103 (define-move-vop move :move
104   (any-reg descriptor-reg immediate)
105   (any-reg descriptor-reg))
106
107 ;;; Make MOVE the check VOP for T so that type check generation
108 ;;; doesn't think it is a hairy type. This also allows checking of a
109 ;;; few of the values in a continuation to fall out.
110 (primitive-type-vop move (:check) t)
111
112 (defun move-immediate (target val &optional tmp-tn)
113   (cond
114     ;; If target is a register, we can just mov it there directly
115     ((and (tn-p target)
116           (sc-is target signed-reg unsigned-reg descriptor-reg any-reg))
117      (inst mov target val))
118     ;; Likewise if the value is small enough.
119     ((typep val '(signed-byte 31))
120      (inst mov target val))
121     ;; Otherwise go through the temporary register
122     (tmp-tn
123      (inst mov tmp-tn val)
124      (inst mov target tmp-tn))
125     (t
126      (error "~A is not a register, no temporary given, and immediate ~A too large" target val))))
127
128 ;;; The MOVE-ARG VOP is used for moving descriptor values into
129 ;;; another frame for argument or known value passing.
130 ;;;
131 ;;; Note: It is not going to be possible to move a constant directly
132 ;;; to another frame, except if the destination is a register and in
133 ;;; this case the loading works out.
134 (define-vop (move-arg)
135   (:args (x :scs (any-reg descriptor-reg immediate) :target y
136             :load-if (not (and (sc-is y any-reg descriptor-reg)
137                                (sc-is x control-stack))))
138          (fp :scs (any-reg)
139              :load-if (not (sc-is y any-reg descriptor-reg))))
140   (:results (y))
141   (:generator 0
142     (sc-case y
143       ((any-reg descriptor-reg)
144        (if (sc-is x immediate)
145            (let ((val (tn-value x)))
146              (etypecase val
147                ((integer 0 0)
148                 (zeroize y))
149                ((or (signed-byte 29) (unsigned-byte 29))
150                 (inst mov y (fixnumize val)))
151                (integer
152                 (move-immediate y (fixnumize val)))
153                (symbol
154                 (load-symbol y val))
155                (character
156                 (inst mov y (logior (ash (char-code val) n-widetag-bits)
157                                     character-widetag)))))
158            (move y x)))
159       ((control-stack)
160        (if (sc-is x immediate)
161            (let ((val (tn-value x)))
162              (if (= (tn-offset fp) esp-offset)
163                  ;; C-call
164                  (etypecase val
165                    (integer
166                     (storew (fixnumize val) fp (tn-offset y)))
167                    (symbol
168                     (storew (+ nil-value (static-symbol-offset val))
169                             fp (tn-offset y)))
170                    (character
171                     (storew (logior (ash (char-code val) n-widetag-bits)
172                                     character-widetag)
173                             fp (tn-offset y))))
174                ;; Lisp stack
175                (etypecase val
176                  (integer
177                   (storew (fixnumize val) fp (- (1+ (tn-offset y)))))
178                  (symbol
179                   (storew (+ nil-value (static-symbol-offset val))
180                           fp (- (1+ (tn-offset y)))))
181                  (character
182                   (storew (logior (ash (char-code val) n-widetag-bits)
183                                   character-widetag)
184                           fp (- (1+ (tn-offset y))))))))
185          (if (= (tn-offset fp) esp-offset)
186              ;; C-call
187              (storew x fp (tn-offset y))
188            ;; Lisp stack
189            (storew x fp (- (1+ (tn-offset y))))))))))
190
191 (define-move-vop move-arg :move-arg
192   (any-reg descriptor-reg)
193   (any-reg descriptor-reg))
194 \f
195 ;;;; ILLEGAL-MOVE
196
197 ;;; This VOP exists just to begin the lifetime of a TN that couldn't
198 ;;; be written legally due to a type error. An error is signalled
199 ;;; before this VOP is so we don't need to do anything (not that there
200 ;;; would be anything sensible to do anyway.)
201 (define-vop (illegal-move)
202   (:args (x) (type))
203   (:results (y))
204   (:ignore y)
205   (:vop-var vop)
206   (:save-p :compute-only)
207   (:generator 666
208     (error-call vop object-not-type-error x type)))
209 \f
210 ;;;; moves and coercions
211
212 ;;; These MOVE-TO-WORD VOPs move a tagged integer to a raw full-word
213 ;;; representation. Similarly, the MOVE-FROM-WORD VOPs converts a raw
214 ;;; integer to a tagged bignum or fixnum.
215
216 ;;; Arg is a fixnum, so just shift it. We need a type restriction
217 ;;; because some possible arg SCs (control-stack) overlap with
218 ;;; possible bignum arg SCs.
219 (define-vop (move-to-word/fixnum)
220   (:args (x :scs (any-reg descriptor-reg) :target y
221             :load-if (not (location= x y))))
222   (:results (y :scs (signed-reg unsigned-reg)
223                :load-if (not (location= x y))))
224   (:arg-types tagged-num)
225   (:note "fixnum untagging")
226   (:generator 1
227     (move y x)
228     (inst sar y  (1- n-lowtag-bits))))
229 (define-move-vop move-to-word/fixnum :move
230   (any-reg descriptor-reg) (signed-reg unsigned-reg))
231
232 ;;; Arg is a non-immediate constant, load it.
233 (define-vop (move-to-word-c)
234   (:args (x :scs (constant)))
235   (:results (y :scs (signed-reg unsigned-reg)))
236   (:note "constant load")
237   (:generator 1
238     (inst mov y (tn-value x))))
239 (define-move-vop move-to-word-c :move
240   (constant) (signed-reg unsigned-reg))
241
242
243 ;;; Arg is a fixnum or bignum, figure out which and load if necessary.
244 (define-vop (move-to-word/integer)
245   (:args (x :scs (descriptor-reg) :target eax))
246   (:results (y :scs (signed-reg unsigned-reg)))
247   (:note "integer to untagged word coercion")
248   (:temporary (:sc unsigned-reg :offset eax-offset
249                    :from (:argument 0) :to (:result 0) :target y) eax)
250   (:generator 4
251     (move eax x)
252     (inst test al-tn 7)                 ; a symbolic constant for this
253     (inst jmp :z FIXNUM)                ; would be nice
254     (loadw y eax bignum-digits-offset other-pointer-lowtag)
255     (inst jmp DONE)
256     FIXNUM
257     (inst sar eax (1- n-lowtag-bits))
258     (move y eax)
259     DONE))
260 (define-move-vop move-to-word/integer :move
261   (descriptor-reg) (signed-reg unsigned-reg))
262
263
264 ;;; Result is a fixnum, so we can just shift. We need the result type
265 ;;; restriction because of the control-stack ambiguity noted above.
266 (define-vop (move-from-word/fixnum)
267   (:args (x :scs (signed-reg unsigned-reg) :target y
268             :load-if (not (location= x y))))
269   (:results (y :scs (any-reg descriptor-reg)
270                :load-if (not (location= x y))))
271   (:result-types tagged-num)
272   (:note "fixnum tagging")
273   (:generator 1
274     (cond ((and (sc-is x signed-reg unsigned-reg)
275                 (not (location= x y)))
276            ;; Uses 7 bytes, but faster on the Pentium
277            (inst lea y (make-ea :qword :index x :scale 8)))
278           (t
279            ;; Uses: If x is a reg 2 + 3; if x = y uses only 3 bytes
280            (move y x)
281            (inst shl y (1- n-lowtag-bits))))))
282 (define-move-vop move-from-word/fixnum :move
283   (signed-reg unsigned-reg) (any-reg descriptor-reg))
284
285 ;;; Result may be a bignum, so we have to check. Use a worst-case cost
286 ;;; to make sure people know they may be number consing.
287 (define-vop (move-from-signed)
288   (:args (x :scs (signed-reg unsigned-reg) :to :result))
289   (:results (y :scs (any-reg descriptor-reg) :from :argument))
290   (:note "signed word to integer coercion")
291   (:node-var node)
292   (:generator 20
293      (aver (not (location= x y)))
294      (let ((bignum (gen-label))
295            (done (gen-label)))
296        ;; We can't do the overflow check with SHL Y, 3, since the
297        ;; state of the overflow flag is only reliably set when
298        ;; shifting by 1. There used to be code here for doing "shift
299        ;; by one, check whether it overflowed" three times. But on all
300        ;; x86-64 processors IMUL is a reasonably fast instruction, so
301        ;; we can just do a straight multiply instead of trying to
302        ;; optimize it to a shift. This is both faster and smaller.
303        ;; -- JES, 2006-07-08
304        (inst imul y x (ash 1 n-fixnum-tag-bits))
305        (inst jmp :o bignum)
306        (emit-label done)
307
308        (assemble (*elsewhere*)
309           (emit-label bignum)
310           (with-fixed-allocation
311               (y bignum-widetag (+ bignum-digits-offset 1) node)
312             (storew x y bignum-digits-offset other-pointer-lowtag))
313           (inst jmp done)))))
314 (define-move-vop move-from-signed :move
315   (signed-reg) (descriptor-reg))
316
317 ;;; Check for fixnum, and possibly allocate one or two word bignum
318 ;;; result. Use a worst-case cost to make sure people know they may be
319 ;;; number consing.
320
321 (define-vop (move-from-unsigned)
322   (:args (x :scs (signed-reg unsigned-reg) :to :save))
323   (:temporary (:sc unsigned-reg) alloc)
324   (:results (y :scs (any-reg descriptor-reg)))
325   (:node-var node)
326   (:note "unsigned word to integer coercion")
327   (:generator 20
328     (aver (not (location= x y)))
329     (aver (not (location= x alloc)))
330     (aver (not (location= y alloc)))
331     (let ((bignum (gen-label))
332           (done (gen-label))
333           (one-word-bignum (gen-label))
334           (L1 (gen-label)))
335       (inst bsr y x)                    ;find msb
336       (inst cmov :z y x)
337       (inst cmp y 60)
338       (inst jmp :ae bignum)
339       (inst lea y (make-ea :qword :index x :scale 8))
340       (emit-label done)
341       (assemble (*elsewhere*)
342          (emit-label bignum)
343          ;; Note: As on the mips port, space for a two word bignum is
344          ;; always allocated and the header size is set to either one
345          ;; or two words as appropriate.
346          (inst cmp y 63)
347          (inst jmp :l one-word-bignum)
348          ;; two word bignum
349          (inst mov y (logior (ash (1- (+ bignum-digits-offset 2))
350                                   n-widetag-bits)
351                              bignum-widetag))
352          (inst jmp L1)
353          (emit-label one-word-bignum)
354          (inst mov y (logior (ash (1- (+ bignum-digits-offset 1))
355                                   n-widetag-bits)
356                              bignum-widetag))
357          (emit-label L1)
358          (pseudo-atomic
359           (allocation alloc (pad-data-block (+ bignum-digits-offset 2)) node)
360           (storew y alloc)
361           (inst lea y (make-ea :byte :base alloc :disp other-pointer-lowtag))
362           (storew x y bignum-digits-offset other-pointer-lowtag))
363          (inst jmp done)))))
364 (define-move-vop move-from-unsigned :move
365   (unsigned-reg) (descriptor-reg))
366
367 ;;; Move untagged numbers.
368 (define-vop (word-move)
369   (:args (x :scs (signed-reg unsigned-reg) :target y
370             :load-if (not (location= x y))))
371   (:results (y :scs (signed-reg unsigned-reg)
372                :load-if
373                (not (or (location= x y)
374                         (and (sc-is x signed-reg unsigned-reg)
375                              (sc-is y signed-stack unsigned-stack))))))
376   (:effects)
377   (:affected)
378   (:note "word integer move")
379   (:generator 0
380     (move y x)))
381 (define-move-vop word-move :move
382   (signed-reg unsigned-reg) (signed-reg unsigned-reg))
383
384 ;;; Move untagged number arguments/return-values.
385 (define-vop (move-word-arg)
386   (:args (x :scs (signed-reg unsigned-reg) :target y)
387          (fp :scs (any-reg) :load-if (not (sc-is y sap-reg))))
388   (:results (y))
389   (:note "word integer argument move")
390   (:generator 0
391     (sc-case y
392       ((signed-reg unsigned-reg)
393        (move y x))
394       ((signed-stack unsigned-stack)
395        (if (= (tn-offset fp) esp-offset)
396            (storew x fp (tn-offset y))  ; c-call
397            (storew x fp (- (1+ (tn-offset y)))))))))
398 (define-move-vop move-word-arg :move-arg
399   (descriptor-reg any-reg signed-reg unsigned-reg) (signed-reg unsigned-reg))
400
401 ;;; Use standard MOVE-ARG and coercion to move an untagged number
402 ;;; to a descriptor passing location.
403 (define-move-vop move-arg :move-arg
404   (signed-reg unsigned-reg) (any-reg descriptor-reg))