0.9.9.33:
[sbcl.git] / src / compiler / sparc / move.lisp
1 ;;;; the Sparc 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   ((null immediate zero)
16    (any-reg descriptor-reg))
17   (let ((val (tn-value x)))
18     (etypecase val
19       (integer
20        (inst li y (fixnumize val)))
21       (null
22        (move y null-tn))
23       (symbol
24        (load-symbol y val))
25       (character
26        (inst li y (logior (ash (char-code val) n-widetag-bits)
27                           character-widetag))))))
28
29 (define-move-fun (load-number 1) (vop x y)
30   ((immediate zero)
31    (signed-reg unsigned-reg))
32   (inst li y (tn-value x)))
33
34 (define-move-fun (load-character 1) (vop x y)
35   ((immediate) (character-reg))
36   (inst li y (char-code (tn-value x))))
37
38 (define-move-fun (load-system-area-pointer 1) (vop x y)
39   ((immediate) (sap-reg))
40   (inst li y (sap-int (tn-value x))))
41
42 (define-move-fun (load-constant 5) (vop x y)
43   ((constant) (descriptor-reg))
44   (loadw y code-tn (tn-offset x) other-pointer-lowtag))
45
46 (define-move-fun (load-stack 5) (vop x y)
47   ((control-stack) (any-reg descriptor-reg))
48   (load-stack-tn y x))
49
50 (define-move-fun (load-number-stack 5) (vop x y)
51   ((character-stack) (character-reg)
52    (sap-stack) (sap-reg)
53    (signed-stack) (signed-reg)
54    (unsigned-stack) (unsigned-reg))
55   (let ((nfp (current-nfp-tn vop)))
56     (loadw y nfp (tn-offset x))))
57
58 (define-move-fun (store-stack 5) (vop x y)
59   ((any-reg descriptor-reg) (control-stack))
60   (store-stack-tn y x))
61
62 (define-move-fun (store-number-stack 5) (vop x y)
63   ((character-reg) (character-stack)
64    (sap-reg) (sap-stack)
65    (signed-reg) (signed-stack)
66    (unsigned-reg) (unsigned-stack))
67   (let ((nfp (current-nfp-tn vop)))
68     (storew x nfp (tn-offset y))))
69
70 \f
71 ;;;; The Move VOP:
72
73 (define-vop (move)
74   (:args (x :target y
75             :scs (any-reg descriptor-reg zero null)
76             :load-if (not (location= x y))))
77   (:results (y :scs (any-reg descriptor-reg)
78                :load-if (not (location= x y))))
79   (:effects)
80   (:affected)
81   (:generator 0
82     (move y x)))
83
84 (define-move-vop move :move
85   (any-reg descriptor-reg)
86   (any-reg descriptor-reg))
87
88 ;;; Make Move the check VOP for T so that type check generation
89 ;;; doesn't think it is a hairy type.  This also allows checking of a
90 ;;; few of the values in a continuation to fall out.
91 (primitive-type-vop move (:check) t)
92
93 ;;; The Move-Arg VOP is used for moving descriptor values into
94 ;;; another frame for argument or known value passing.
95 (define-vop (move-arg)
96   (:args (x :target y
97             :scs (any-reg descriptor-reg zero null))
98          (fp :scs (any-reg)
99              :load-if (not (sc-is y any-reg descriptor-reg))))
100   (:results (y))
101   (:generator 0
102     (sc-case y
103       ((any-reg descriptor-reg)
104        (move y x))
105       (control-stack
106        (storew x fp (tn-offset y))))))
107
108 (define-move-vop move-arg :move-arg
109   (any-reg descriptor-reg)
110   (any-reg descriptor-reg))
111 \f
112 ;;;; ILLEGAL-MOVE
113
114 ;;; This VOP exists just to begin the lifetime of a TN that couldn't
115 ;;; be written legally due to a type error.  An error is signalled
116 ;;; before this VOP is so we don't need to do anything (not that there
117 ;;; would be anything sensible to do anyway.)
118 (define-vop (illegal-move)
119   (:args (x) (type))
120   (:results (y))
121   (:ignore y)
122   (:vop-var vop)
123   (:save-p :compute-only)
124   (:generator 666
125     (error-call vop object-not-type-error x type)))
126 \f
127 ;;;; moves and coercions:
128
129 ;;; These MOVE-TO-WORD VOPs move a tagged integer to a raw full-word
130 ;;; representation.  Similarly, the MOVE-FROM-WORD VOPs converts a raw
131 ;;; integer to a tagged bignum or fixnum.
132
133 ;;; Arg is a fixnum, so just shift it.  We need a type restriction
134 ;;; because some possible arg SCs (control-stack) overlap with
135 ;;; possible bignum arg SCs.
136 (define-vop (move-to-word/fixnum)
137   (:args (x :scs (any-reg descriptor-reg)))
138   (:results (y :scs (signed-reg unsigned-reg)))
139   (:arg-types tagged-num)
140   (:note "fixnum untagging")
141   (:generator 1
142     (inst sra y x n-fixnum-tag-bits)))
143
144 (define-move-vop move-to-word/fixnum :move
145   (any-reg descriptor-reg) (signed-reg unsigned-reg))
146
147 ;;; Arg is a non-immediate constant, load it.
148 (define-vop (move-to-word-c)
149   (:args (x :scs (constant)))
150   (:results (y :scs (signed-reg unsigned-reg)))
151   (:note "constant load")
152   (:generator 1
153     (inst li y (tn-value x))))
154
155 (define-move-vop move-to-word-c :move
156   (constant) (signed-reg unsigned-reg))
157
158
159 ;;; Arg is a fixnum or bignum, figure out which and load if necessary.
160 (define-vop (move-to-word/integer)
161   (:args (x :scs (descriptor-reg)))
162   (:results (y :scs (signed-reg unsigned-reg)))
163   (:note "integer to untagged word coercion")
164   (:temporary (:scs (non-descriptor-reg)) temp)
165   (:generator 4
166     (let ((done (gen-label)))
167       (inst andcc temp x fixnum-tag-mask)
168       (inst b :eq done)
169       (inst sra y x n-fixnum-tag-bits)
170
171       (loadw y x bignum-digits-offset other-pointer-lowtag)
172
173       (emit-label done))))
174
175 (define-move-vop move-to-word/integer :move
176   (descriptor-reg) (signed-reg unsigned-reg))
177
178 ;;; Result is a fixnum, so we can just shift.  We need the result type
179 ;;; restriction because of the control-stack ambiguity noted above.
180 (define-vop (move-from-word/fixnum)
181   (:args (x :scs (signed-reg unsigned-reg)))
182   (:results (y :scs (any-reg descriptor-reg)))
183   (:result-types tagged-num)
184   (:note "fixnum tagging")
185   (:generator 1
186     (inst sll y x n-fixnum-tag-bits)))
187
188 (define-move-vop move-from-word/fixnum :move
189   (signed-reg unsigned-reg) (any-reg descriptor-reg))
190
191
192 ;;; Result may be a bignum, so we have to check.  Use a worst-case
193 ;;; cost to make sure people know they may be number consing.
194 (define-vop (move-from-signed)
195   (:args (arg :scs (signed-reg unsigned-reg) :target x))
196   (:results (y :scs (any-reg descriptor-reg)))
197   (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) x temp)
198   (:note "signed word to integer coercion")
199   (:generator 20
200     (move x arg)
201     (let ((fixnum (gen-label))
202           (done (gen-label)))
203       (inst sra temp x n-positive-fixnum-bits)
204       (inst cmp temp)
205       (inst b :eq fixnum)
206       (inst orncc temp zero-tn temp)
207       (inst b :eq done)
208       (inst sll y x n-fixnum-tag-bits)
209
210       (with-fixed-allocation
211         (y temp bignum-widetag (1+ bignum-digits-offset))
212         (storew x y bignum-digits-offset other-pointer-lowtag))
213       (inst b done)
214       (inst nop)
215
216       (emit-label fixnum)
217       (inst sll y x n-fixnum-tag-bits)
218       (emit-label done))))
219
220 (define-move-vop move-from-signed :move
221   (signed-reg) (descriptor-reg))
222
223
224 ;;; Check for fixnum, and possibly allocate one or two word bignum
225 ;;; result.  Use a worst-case cost to make sure people know they may
226 ;;; be number consing.
227 (define-vop (move-from-unsigned)
228   (:args (arg :scs (signed-reg unsigned-reg) :target x))
229   (:results (y :scs (any-reg descriptor-reg)))
230   (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) x temp)
231   (:note "unsigned word to integer coercion")
232   (:generator 20
233     (move x arg)
234     (let ((done (gen-label))
235           (one-word (gen-label)))
236       (inst sra temp x n-positive-fixnum-bits)
237       (inst cmp temp)
238       (inst b :eq done)
239       (inst sll y x n-fixnum-tag-bits)
240
241       ;; We always allocate 2 words even if we don't need it.  (The
242       ;; copying GC will take care of freeing the unused extra word.)
243       (with-fixed-allocation
244           (y temp bignum-widetag (+ 2 bignum-digits-offset))
245         (inst cmp x)
246         (inst b :ge one-word)
247         (inst li temp (logior (ash 1 n-widetag-bits) bignum-widetag))
248         (inst li temp (logior (ash 2 n-widetag-bits) bignum-widetag))
249         (emit-label one-word)
250         ;; Set the header word, then the actual digit.  The extra
251         ;; digit, if any, is automatically set to zero, so we don't
252         ;; have to.
253         (storew temp y 0 other-pointer-lowtag)
254         (storew x y bignum-digits-offset other-pointer-lowtag))
255       (emit-label done))))
256
257 (define-move-vop move-from-unsigned :move
258   (unsigned-reg) (descriptor-reg))
259
260
261 ;;; Move untagged numbers.
262 (define-vop (word-move)
263   (:args (x :target y
264             :scs (signed-reg unsigned-reg)
265             :load-if (not (location= x y))))
266   (:results (y :scs (signed-reg unsigned-reg)
267                :load-if (not (location= x y))))
268   (:effects)
269   (:affected)
270   (:note "word integer move")
271   (:generator 0
272     (move y x)))
273
274 (define-move-vop word-move :move
275   (signed-reg unsigned-reg) (signed-reg unsigned-reg))
276
277
278 ;;; Move untagged number arguments/return-values.
279 (define-vop (move-word-arg)
280   (:args (x :target y
281             :scs (signed-reg unsigned-reg))
282          (fp :scs (any-reg)
283              :load-if (not (sc-is y sap-reg))))
284   (:results (y))
285   (:note "word integer argument move")
286   (:generator 0
287     (sc-case y
288       ((signed-reg unsigned-reg)
289        (move y x))
290       ((signed-stack unsigned-stack)
291        (storew x fp (tn-offset y))))))
292
293 (define-move-vop move-word-arg :move-arg
294   (descriptor-reg any-reg signed-reg unsigned-reg) (signed-reg unsigned-reg))
295
296
297 ;;; Use standard MOVE-ARGUMENT + coercion to move an untagged number
298 ;;; to a descriptor passing location.
299 (define-move-vop move-arg :move-arg
300   (signed-reg unsigned-reg) (any-reg descriptor-reg))