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