cleanup: partial long cleanup in sniff_code_object and gencgc_apply_code_fixups
[sbcl.git] / src / compiler / x86 / move.lisp
1 ;;;; the x86 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 (define-move-fun (load-immediate 1) (vop x y)
15   ((immediate)
16    (any-reg descriptor-reg))
17   (let ((val (encode-value-if-immediate x)))
18     (if (zerop val)
19         (inst xor y y)
20         (inst mov y val))))
21
22 (define-move-fun (load-number 1) (vop x y)
23   ((immediate) (signed-reg unsigned-reg))
24   (let ((val (tn-value x)))
25     (if (zerop val)
26         (inst xor y y)
27         (inst mov y val))))
28
29 (define-move-fun (load-character 1) (vop x y)
30   ((immediate) (character-reg))
31   (inst mov y (char-code (tn-value x))))
32
33 (define-move-fun (load-system-area-pointer 1) (vop x y)
34   ((immediate) (sap-reg))
35   (inst mov y (sap-int (tn-value x))))
36
37 (define-move-fun (load-constant 5) (vop x y)
38   ((constant) (descriptor-reg any-reg))
39   (inst mov y x))
40
41 (define-move-fun (load-stack 5) (vop x y)
42   ((control-stack) (any-reg descriptor-reg)
43    (character-stack) (character-reg)
44    (sap-stack) (sap-reg)
45    (signed-stack) (signed-reg)
46    (unsigned-stack) (unsigned-reg))
47   (inst mov y x))
48
49 (define-move-fun (store-stack 5) (vop x y)
50   ((any-reg descriptor-reg) (control-stack)
51    (character-reg) (character-stack)
52    (sap-reg) (sap-stack)
53    (signed-reg) (signed-stack)
54    (unsigned-reg) (unsigned-stack))
55   (inst mov y x))
56 \f
57 ;;;; the MOVE VOP
58 (define-vop (move)
59   (:args (x :scs (any-reg descriptor-reg immediate) :target y
60             :load-if (not (location= x y))))
61   (:results (y :scs (any-reg descriptor-reg)
62                :load-if
63                (not (or (location= x y)
64                         (and (sc-is x any-reg descriptor-reg immediate)
65                              (sc-is y control-stack))))))
66   (:effects)
67   (:affected)
68   (:generator 0
69     (if (and (sc-is x immediate)
70              (sc-is y any-reg descriptor-reg control-stack))
71         (let ((val (encode-value-if-immediate x)))
72           (if (and (zerop val) (sc-is y any-reg descriptor-reg))
73               (inst xor y y)
74               (inst mov y val)))
75       (move y x))))
76
77 (define-move-vop move :move
78   (any-reg descriptor-reg immediate)
79   (any-reg descriptor-reg))
80
81 ;;; Make MOVE the check VOP for T so that type check generation
82 ;;; doesn't think it is a hairy type. This also allows checking of a
83 ;;; few of the values in a continuation to fall out.
84 (primitive-type-vop move (:check) t)
85
86 ;;; The MOVE-ARG VOP is used for moving descriptor values into
87 ;;; another frame for argument or known value passing.
88 ;;;
89 ;;; Note: It is not going to be possible to move a constant directly
90 ;;; to another frame, except if the destination is a register and in
91 ;;; this case the loading works out.
92 (define-vop (move-arg)
93   (:args (x :scs (any-reg descriptor-reg immediate) :target y
94             :load-if (not (and (sc-is y any-reg descriptor-reg)
95                                (sc-is x control-stack))))
96          (fp :scs (any-reg)
97              :load-if (not (sc-is y any-reg descriptor-reg))))
98   (:results (y))
99   (:generator 0
100     (sc-case y
101       ((any-reg descriptor-reg)
102        (if (sc-is x immediate)
103            (let ((val (encode-value-if-immediate x)))
104              (if (zerop val)
105                  (inst xor y y)
106                  (inst mov y val)))
107          (move y x)))
108       ((control-stack)
109        (let ((frame-offset (if (= (tn-offset fp) esp-offset)
110                                ;; C-call
111                                (tn-offset y)
112                                ;; Lisp stack
113                                (frame-word-offset (tn-offset y)))))
114          (storew (encode-value-if-immediate x) fp frame-offset))))))
115
116 (define-move-vop move-arg :move-arg
117   (any-reg descriptor-reg)
118   (any-reg descriptor-reg))
119 \f
120 ;;;; ILLEGAL-MOVE
121
122 ;;; This VOP exists just to begin the lifetime of a TN that couldn't
123 ;;; be written legally due to a type error. An error is signalled
124 ;;; before this VOP is so we don't need to do anything (not that there
125 ;;; would be anything sensible to do anyway.)
126 (define-vop (illegal-move)
127   (:args (x) (type))
128   (:results (y))
129   (:ignore y)
130   (:vop-var vop)
131   (:save-p :compute-only)
132   (:generator 666
133     (error-call vop 'object-not-type-error x type)))
134 \f
135 ;;;; moves and coercions
136
137 ;;; These MOVE-TO-WORD VOPs move a tagged integer to a raw full-word
138 ;;; representation. Similarly, the MOVE-FROM-WORD VOPs converts a raw
139 ;;; integer to a tagged bignum or fixnum.
140
141 ;;; Arg is a fixnum, so just shift it. We need a type restriction
142 ;;; because some possible arg SCs (control-stack) overlap with
143 ;;; possible bignum arg SCs.
144 (define-vop (move-to-word/fixnum)
145   (:args (x :scs (any-reg descriptor-reg) :target y
146             :load-if (not (location= x y))))
147   (:results (y :scs (signed-reg unsigned-reg)
148                :load-if (not (location= x y))))
149   (:arg-types tagged-num)
150   (:note "fixnum untagging")
151   (:generator 1
152     (move y x)
153     (inst sar y n-fixnum-tag-bits)))
154 (define-move-vop move-to-word/fixnum :move
155   (any-reg descriptor-reg) (signed-reg unsigned-reg))
156
157 ;;; Arg is a non-immediate constant, load it.
158 (define-vop (move-to-word-c)
159   (:args (x :scs (constant)))
160   (:results (y :scs (signed-reg unsigned-reg)))
161   (:note "constant load")
162   (:generator 1
163     (cond ((sb!c::tn-leaf x)
164            (inst mov y (tn-value x)))
165           (t
166            (inst mov y x)
167            (inst sar y n-fixnum-tag-bits)))))
168 (define-move-vop move-to-word-c :move
169   (constant) (signed-reg unsigned-reg))
170
171
172 ;;; Arg is a fixnum or bignum, figure out which and load if necessary.
173 (define-vop (move-to-word/integer)
174   (:args (x :scs (descriptor-reg) :target eax))
175   (:results (y :scs (signed-reg unsigned-reg)))
176   (:note "integer to untagged word coercion")
177   (:temporary (:sc unsigned-reg :offset eax-offset
178                    :from (:argument 0) :to (:result 0) :target y) eax)
179   (:generator 4
180     (move eax x)
181     (inst test al-tn fixnum-tag-mask)
182     (inst jmp :z fixnum)
183     (loadw y eax bignum-digits-offset other-pointer-lowtag)
184     (inst jmp done)
185     FIXNUM
186     (inst sar eax n-fixnum-tag-bits)
187     (move y eax)
188     DONE))
189 (define-move-vop move-to-word/integer :move
190   (descriptor-reg) (signed-reg unsigned-reg))
191
192
193 ;;; Result is a fixnum, so we can just shift. We need the result type
194 ;;; restriction because of the control-stack ambiguity noted above.
195 (define-vop (move-from-word/fixnum)
196   (:args (x :scs (signed-reg unsigned-reg) :target y
197             :load-if (not (location= x y))))
198   (:results (y :scs (any-reg descriptor-reg)
199                :load-if (not (location= x y))))
200   (:result-types tagged-num)
201   (:note "fixnum tagging")
202   (:generator 1
203     (cond ((and (sc-is x signed-reg unsigned-reg)
204                 (not (location= x y)))
205            ;; Uses 7 bytes, but faster on the Pentium
206            (inst lea y (make-ea :dword :index x
207                                 :scale (ash 1 n-fixnum-tag-bits))))
208           (t
209            ;; Uses: If x is a reg 2 + 3; if x = y uses only 3 bytes
210            (move y x)
211            (inst shl y n-fixnum-tag-bits)))))
212 (define-move-vop move-from-word/fixnum :move
213   (signed-reg unsigned-reg) (any-reg descriptor-reg))
214
215 ;;; Convert an untagged signed word to a lispobj -- fixnum or bignum
216 ;;; as the case may be. Fixnum case inline, bignum case in an assembly
217 ;;; routine.
218 (define-vop (move-from-signed)
219   (:args (x :scs (signed-reg unsigned-reg) :to :result))
220   (:results (y :scs (any-reg descriptor-reg) :from :argument))
221   (:note "signed word to integer coercion")
222   ;; Worst case cost to make sure people know they may be number consing.
223   (:generator 20
224      (aver (not (location= x y)))
225      (let ((done (gen-label)))
226        (inst imul y x (ash 1 n-fixnum-tag-bits))
227        (inst jmp :no done)
228        (inst mov y x)
229        (inst call (make-fixup (ecase (tn-offset y)
230                                 (#.eax-offset 'alloc-signed-bignum-in-eax)
231                                 (#.ebx-offset 'alloc-signed-bignum-in-ebx)
232                                 (#.ecx-offset 'alloc-signed-bignum-in-ecx)
233                                 (#.edx-offset 'alloc-signed-bignum-in-edx)
234                                 (#.esi-offset 'alloc-signed-bignum-in-esi)
235                                 (#.edi-offset 'alloc-signed-bignum-in-edi))
236                               :assembly-routine))
237        (emit-label done))))
238 (define-move-vop move-from-signed :move
239   (signed-reg) (descriptor-reg))
240
241 ;;; Convert an untagged unsigned word to a lispobj -- fixnum or bignum
242 ;;; as the case may be. Fixnum case inline, bignum case in an assembly
243 ;;; routine.
244 (define-vop (move-from-unsigned)
245   (:args (x :scs (signed-reg unsigned-reg) :to :result))
246   (:results (y :scs (any-reg descriptor-reg) :from :argument))
247   (:note "unsigned word to integer coercion")
248   ;; Worst case cost to make sure people know they may be number consing.
249   (:generator 20
250     (aver (not (location= x y)))
251     (let ((done (gen-label)))
252       ;; The assembly routines test the sign flag from this one, so if
253       ;; you change stuff here, make sure the sign flag doesn't get
254       ;; overwritten before the CALL!
255       (inst test x #.(ash lowtag-mask n-positive-fixnum-bits))
256       ;; Faster but bigger then SHL Y 2. The cost of doing this speculatively
257       ;; is noise compared to bignum consing if that is needed.
258       (inst lea y (make-ea :dword :index x :scale (ash 1 n-fixnum-tag-bits)))
259       (inst jmp :z done)
260       (inst mov y x)
261       (inst call (make-fixup (ecase (tn-offset y)
262                                (#.eax-offset 'alloc-unsigned-bignum-in-eax)
263                                (#.ebx-offset 'alloc-unsigned-bignum-in-ebx)
264                                (#.ecx-offset 'alloc-unsigned-bignum-in-ecx)
265                                (#.edx-offset 'alloc-unsigned-bignum-in-edx)
266                                (#.edi-offset 'alloc-unsigned-bignum-in-edi)
267                                (#.esi-offset 'alloc-unsigned-bignum-in-esi))
268                              :assembly-routine))
269       (emit-label done))))
270 (define-move-vop move-from-unsigned :move
271   (unsigned-reg) (descriptor-reg))
272
273 ;;; Move untagged numbers.
274 (define-vop (word-move)
275   (:args (x :scs (signed-reg unsigned-reg) :target y
276             :load-if (not (location= x y))))
277   (:results (y :scs (signed-reg unsigned-reg)
278                :load-if
279                (not (or (location= x y)
280                         (and (sc-is x signed-reg unsigned-reg)
281                              (sc-is y signed-stack unsigned-stack))))))
282   (:effects)
283   (:affected)
284   (:note "word integer move")
285   (:generator 0
286     (move y x)))
287 (define-move-vop word-move :move
288   (signed-reg unsigned-reg) (signed-reg unsigned-reg))
289
290 ;;; Move untagged number arguments/return-values.
291 (define-vop (move-word-arg)
292   (:args (x :scs (signed-reg unsigned-reg) :target y)
293          (fp :scs (any-reg) :load-if (not (sc-is y sap-reg))))
294   (:results (y))
295   (:note "word integer argument move")
296   (:generator 0
297     (sc-case y
298       ((signed-reg unsigned-reg)
299        (move y x))
300       ((signed-stack unsigned-stack)
301        (if (= (tn-offset fp) esp-offset)
302            (storew x fp (tn-offset y))  ; c-call
303            (storew x fp (frame-word-offset (tn-offset y))))))))
304 (define-move-vop move-word-arg :move-arg
305   (descriptor-reg any-reg signed-reg unsigned-reg) (signed-reg unsigned-reg))
306
307 ;;; Use standard MOVE-ARG and coercion to move an untagged number
308 ;;; to a descriptor passing location.
309 (define-move-vop move-arg :move-arg
310   (signed-reg unsigned-reg) (any-reg descriptor-reg))