1 ;;;; the Sparc 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
)
15 ((null immediate zero
)
16 (any-reg descriptor-reg
))
17 (let ((val (tn-value x
)))
20 (inst li y
(fixnumize val
)))
26 (inst li y
(logior (ash (char-code val
) n-widetag-bits
)
27 character-widetag
))))))
29 (define-move-fun (load-number 1) (vop x y
)
31 (signed-reg unsigned-reg
))
32 (inst li y
(tn-value x
)))
34 (define-move-fun (load-character 1) (vop x y
)
35 ((immediate) (character-reg))
36 (inst li y
(char-code (tn-value x
))))
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
))))
42 (define-move-fun (load-constant 5) (vop x y
)
43 ((constant) (descriptor-reg))
44 ;; Does the (positive) offset fit into our signed 13 bit immediate?
45 ;; Else go through a temporary register. Note that PPC (for example)
46 ;; does not try to support arbitrarily large constant offsets, but PPC
47 ;; supports 16 bit immediates, so the restriction is not as severe
51 ((<= (- (ash (tn-offset x
) word-shift
) other-pointer-lowtag
)
53 (loadw y code-tn
(tn-offset x
) other-pointer-lowtag
))
55 ;; Use LIP as a temporary. This should be OK, because LIP is only
56 ;; used within VOPs, whereas we get called to supply the VOP's
57 ;; parameters much earlier. And LIP-TN is relative to CODE-TN, so
58 ;; the GC should be fine with this.
60 ;; When ADDing the offset, we need multiple steps, because ADD's
61 ;; immediate has the same size restriction as LOADW's. Take care
62 ;; to add in word-sized steps, so that the LIP remains valid.
63 (let ((stepsize (logandc2 (1- (ash 1 nbits
)) (1- (ash 1 word-shift
)))))
64 (multiple-value-bind (q r
)
65 (truncate (ash (tn-offset x
) word-shift
) stepsize
)
66 (dotimes (x q
) (inst add lip-tn stepsize
))
67 (when (plusp r
) (inst add lip-tn r
))))
68 (loadw y lip-tn
0 other-pointer-lowtag
)))))
70 (define-move-fun (load-stack 5) (vop x y
)
71 ((control-stack) (any-reg descriptor-reg
))
74 (define-move-fun (load-number-stack 5) (vop x y
)
75 ((character-stack) (character-reg)
77 (signed-stack) (signed-reg)
78 (unsigned-stack) (unsigned-reg))
79 (let ((nfp (current-nfp-tn vop
)))
80 (loadw y nfp
(tn-offset x
))))
82 (define-move-fun (store-stack 5) (vop x y
)
83 ((any-reg descriptor-reg
) (control-stack))
86 (define-move-fun (store-number-stack 5) (vop x y
)
87 ((character-reg) (character-stack)
89 (signed-reg) (signed-stack)
90 (unsigned-reg) (unsigned-stack))
91 (let ((nfp (current-nfp-tn vop
)))
92 (storew x nfp
(tn-offset y
))))
99 :scs
(any-reg descriptor-reg zero null
)
100 :load-if
(not (location= x y
))))
101 (:results
(y :scs
(any-reg descriptor-reg
)
102 :load-if
(not (location= x y
))))
108 (define-move-vop move
:move
109 (any-reg descriptor-reg
)
110 (any-reg descriptor-reg
))
112 ;;; Make Move the check VOP for T so that type check generation
113 ;;; doesn't think it is a hairy type. This also allows checking of a
114 ;;; few of the values in a continuation to fall out.
115 (primitive-type-vop move
(:check
) t
)
117 ;;; The Move-Arg VOP is used for moving descriptor values into
118 ;;; another frame for argument or known value passing.
119 (define-vop (move-arg)
121 :scs
(any-reg descriptor-reg zero null
))
123 :load-if
(not (sc-is y any-reg descriptor-reg
))))
127 ((any-reg descriptor-reg
)
130 (storew x fp
(tn-offset y
))))))
132 (define-move-vop move-arg
:move-arg
133 (any-reg descriptor-reg
)
134 (any-reg descriptor-reg
))
136 ;;;; moves and coercions:
138 ;;; These MOVE-TO-WORD VOPs move a tagged integer to a raw full-word
139 ;;; representation. Similarly, the MOVE-FROM-WORD VOPs converts a raw
140 ;;; integer to a tagged bignum or fixnum.
142 ;;; Arg is a fixnum, so just shift it. We need a type restriction
143 ;;; because some possible arg SCs (control-stack) overlap with
144 ;;; possible bignum arg SCs.
145 (define-vop (move-to-word/fixnum
)
146 (:args
(x :scs
(any-reg descriptor-reg
)))
147 (:results
(y :scs
(signed-reg unsigned-reg
)))
148 (:arg-types tagged-num
)
149 (:note
"fixnum untagging")
151 (inst sra y x n-fixnum-tag-bits
)))
153 (define-move-vop move-to-word
/fixnum
:move
154 (any-reg descriptor-reg
) (signed-reg unsigned-reg
))
156 ;;; Arg is a non-immediate constant, load it.
157 (define-vop (move-to-word-c)
158 (:args
(x :scs
(constant)))
159 (:results
(y :scs
(signed-reg unsigned-reg
)))
160 (:note
"constant load")
162 (cond ((sb!c
::tn-leaf x
)
163 (inst li y
(tn-value x
)))
165 (loadw y code-tn
(tn-offset x
) other-pointer-lowtag
)
166 (inst sra y y n-fixnum-tag-bits
)))))
168 (define-move-vop move-to-word-c
:move
169 (constant) (signed-reg unsigned-reg
))
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)))
175 (:results
(y :scs
(signed-reg unsigned-reg
)))
176 (:note
"integer to untagged word coercion")
177 (:temporary
(:scs
(non-descriptor-reg)) temp
)
179 (let ((done (gen-label)))
180 (inst andcc temp x fixnum-tag-mask
)
182 (inst sra y x n-fixnum-tag-bits
)
184 (loadw y x bignum-digits-offset other-pointer-lowtag
)
188 (define-move-vop move-to-word
/integer
:move
189 (descriptor-reg) (signed-reg unsigned-reg
))
191 ;;; Result is a fixnum, so we can just shift. We need the result type
192 ;;; restriction because of the control-stack ambiguity noted above.
193 (define-vop (move-from-word/fixnum
)
194 (:args
(x :scs
(signed-reg unsigned-reg
)))
195 (:results
(y :scs
(any-reg descriptor-reg
)))
196 (:result-types tagged-num
)
197 (:note
"fixnum tagging")
199 (inst sll y x n-fixnum-tag-bits
)))
201 (define-move-vop move-from-word
/fixnum
:move
202 (signed-reg unsigned-reg
) (any-reg descriptor-reg
))
205 ;;; Result may be a bignum, so we have to check. Use a worst-case
206 ;;; cost to make sure people know they may be number consing.
207 (define-vop (move-from-signed)
208 (:args
(arg :scs
(signed-reg unsigned-reg
) :target x
))
209 (:results
(y :scs
(any-reg descriptor-reg
)))
210 (:temporary
(:scs
(non-descriptor-reg) :from
(:argument
0)) x temp
)
211 (:note
"signed word to integer coercion")
214 (let ((fixnum (gen-label))
216 (inst sra temp x n-positive-fixnum-bits
)
219 (inst orncc temp zero-tn temp
)
221 (inst sll y x n-fixnum-tag-bits
)
223 (with-fixed-allocation
224 (y temp bignum-widetag
(1+ bignum-digits-offset
))
225 (storew x y bignum-digits-offset other-pointer-lowtag
))
230 (inst sll y x n-fixnum-tag-bits
)
233 (define-move-vop move-from-signed
:move
234 (signed-reg) (descriptor-reg))
237 ;;; Check for fixnum, and possibly allocate one or two word bignum
238 ;;; result. Use a worst-case cost to make sure people know they may
239 ;;; be number consing.
240 (define-vop (move-from-unsigned)
241 (:args
(arg :scs
(signed-reg unsigned-reg
) :target x
))
242 (:results
(y :scs
(any-reg descriptor-reg
)))
243 (:temporary
(:scs
(non-descriptor-reg) :from
(:argument
0)) x temp
)
244 (:note
"unsigned word to integer coercion")
247 (let ((done (gen-label))
248 (one-word (gen-label)))
249 (inst sra temp x n-positive-fixnum-bits
)
252 (inst sll y x n-fixnum-tag-bits
)
254 ;; We always allocate 2 words even if we don't need it. (The
255 ;; copying GC will take care of freeing the unused extra word.)
256 (with-fixed-allocation
257 (y temp bignum-widetag
(+ 2 bignum-digits-offset
))
259 (inst b
:ge one-word
)
260 (inst li temp
(logior (ash 1 n-widetag-bits
) bignum-widetag
))
261 (inst li temp
(logior (ash 2 n-widetag-bits
) bignum-widetag
))
262 (emit-label one-word
)
263 ;; Set the header word, then the actual digit. The extra
264 ;; digit, if any, is automatically set to zero, so we don't
266 (storew temp y
0 other-pointer-lowtag
)
267 (storew x y bignum-digits-offset other-pointer-lowtag
))
270 (define-move-vop move-from-unsigned
:move
271 (unsigned-reg) (descriptor-reg))
274 ;;; Move untagged numbers.
275 (define-vop (word-move)
277 :scs
(signed-reg unsigned-reg
)
278 :load-if
(not (location= x y
))))
279 (:results
(y :scs
(signed-reg unsigned-reg
)
280 :load-if
(not (location= x y
))))
283 (:note
"word integer move")
287 (define-move-vop word-move
:move
288 (signed-reg unsigned-reg
) (signed-reg unsigned-reg
))
291 ;;; Move untagged number arguments/return-values.
292 (define-vop (move-word-arg)
294 :scs
(signed-reg unsigned-reg
))
296 :load-if
(not (sc-is y signed-reg unsigned-reg
))))
298 (:note
"word integer argument move")
301 ((signed-reg unsigned-reg
)
303 ((signed-stack unsigned-stack
)
304 (storew x fp
(tn-offset y
))))))
306 (define-move-vop move-word-arg
:move-arg
307 (descriptor-reg any-reg signed-reg unsigned-reg
) (signed-reg unsigned-reg
))
310 ;;; Use standard MOVE-ARGUMENT + coercion to move an untagged number
311 ;;; to a descriptor passing location.
312 (define-move-vop move-arg
:move-arg
313 (signed-reg unsigned-reg
) (any-reg descriptor-reg
))