1 ;;;; the PPC 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 lr y
(fixnumize val
)))
26 (inst lr 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 lr y
(tn-value x
)))
34 (define-move-fun (load-character 1) (vop x y
)
35 ((immediate) (character-reg))
36 (inst lr y
(char-code (tn-value x
))))
38 (define-move-fun (load-system-area-pointer 1) (vop x y
)
39 ((immediate) (sap-reg))
40 (inst lr y
(sap-int (tn-value x
))))
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
))
46 (define-move-fun (load-stack 5) (vop x y
)
47 ((control-stack) (any-reg descriptor-reg
))
50 (define-move-fun (load-number-stack 5) (vop x y
)
51 ((character-stack) (character-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
))))
58 (define-move-fun (store-stack 5) (vop x y
)
59 ((any-reg descriptor-reg
) (control-stack))
62 (define-move-fun (store-number-stack 5) (vop x y
)
63 ((character-reg) (character-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
))))
74 :scs
(any-reg descriptor-reg zero null
)
75 :load-if
(not (location= x y
))))
76 (:results
(y :scs
(any-reg descriptor-reg control-stack
)
77 :load-if
(not (location= x y
))))
81 (cond ((location= x y
))
82 ((sc-is y control-stack
)
87 (define-move-vop move
:move
88 (any-reg descriptor-reg
)
89 (any-reg descriptor-reg
))
91 ;;; The MOVE-ARG VOP is used for moving descriptor values into another
92 ;;; frame for argument or known value passing.
93 (define-vop (move-arg)
95 :scs
(any-reg descriptor-reg zero null
))
97 :load-if
(not (sc-is y any-reg descriptor-reg
))))
101 ((any-reg descriptor-reg
)
104 (storew x fp
(tn-offset y
))))))
106 (define-move-vop move-arg
:move-arg
107 (any-reg descriptor-reg
)
108 (any-reg descriptor-reg
))
110 ;;;; Moves and coercions:
112 ;;; These MOVE-TO-WORD VOPs move a tagged integer to a raw full-word
113 ;;; representation. Similarly, the MOVE-FROM-WORD VOPs converts a raw integer
114 ;;; to a tagged bignum or fixnum.
116 ;;; ARG is a fixnum, so just shift it. We need a type restriction because some
117 ;;; possible arg SCs (control-stack) overlap with possible bignum arg SCs.
118 (define-vop (move-to-word/fixnum
)
119 (:args
(x :scs
(any-reg descriptor-reg
)))
120 (:results
(y :scs
(signed-reg unsigned-reg
)))
121 (:arg-types tagged-num
)
122 (:note
"fixnum untagging")
124 (inst srawi y x n-fixnum-tag-bits
)))
125 (define-move-vop move-to-word
/fixnum
:move
126 (any-reg descriptor-reg
) (signed-reg unsigned-reg
))
128 ;;; ARG is a non-immediate constant; load it.
129 (define-vop (move-to-word-c)
130 (:args
(x :scs
(constant)))
131 (:results
(y :scs
(signed-reg unsigned-reg
)))
132 (:note
"constant load")
134 (cond ((sb!c
::tn-leaf x
)
135 (inst lr y
(tn-value x
)))
137 (loadw y code-tn
(tn-offset x
) other-pointer-lowtag
)
138 (inst srawi y y n-fixnum-tag-bits
)))))
139 (define-move-vop move-to-word-c
:move
140 (constant) (signed-reg unsigned-reg
))
142 ;;; ARG is a fixnum or bignum; figure out which and load if necessary.
143 (define-vop (move-to-word/integer
)
144 (:args
(x :scs
(descriptor-reg)))
145 (:results
(y :scs
(signed-reg unsigned-reg
)))
146 (:note
"integer to untagged word coercion")
147 (:temporary
(:scs
(non-descriptor-reg)) temp
)
149 (let ((done (gen-label)))
150 (inst andi. temp x fixnum-tag-mask
)
151 (inst srawi y x n-fixnum-tag-bits
)
154 (loadw y x bignum-digits-offset other-pointer-lowtag
)
157 (define-move-vop move-to-word
/integer
:move
158 (descriptor-reg) (signed-reg unsigned-reg
))
160 ;;; RESULT is a fixnum, so we can just shift. We need the result type
161 ;;; restriction because of the control-stack ambiguity noted above.
162 (define-vop (move-from-word/fixnum
)
163 (:args
(x :scs
(signed-reg unsigned-reg
)))
164 (:results
(y :scs
(any-reg descriptor-reg
)))
165 (:result-types tagged-num
)
166 (:note
"fixnum tagging")
168 (inst slwi y x n-fixnum-tag-bits
)))
169 (define-move-vop move-from-word
/fixnum
:move
170 (signed-reg unsigned-reg
) (any-reg descriptor-reg
))
172 ;;; RESULT may be a bignum, so we have to check. Use a worst-case
173 ;;; cost to make sure people know they may be number consing.
174 (define-vop (move-from-signed)
175 (:args
(arg :scs
(signed-reg unsigned-reg
) :target x
))
176 (:results
(y :scs
(any-reg descriptor-reg
)))
177 (:temporary
(:scs
(non-descriptor-reg) :from
(:argument
0)) x temp
)
178 (:temporary
(:sc non-descriptor-reg
:offset nl3-offset
) pa-flag
)
179 (:note
"signed word to integer coercion")
182 (let ((done (gen-label)))
183 (inst mtxer zero-tn
) ; clear sticky overflow bit in XER, CR0
184 (inst addo temp x x
) ; set XER OV if top two bits differ
185 (inst addo. temp temp temp
) ; set CR0 SO if any top three bits differ
186 (inst slwi y x n-fixnum-tag-bits
) ; assume fixnum (tagged ok, maybe lost some high bits)
189 (with-fixed-allocation (y pa-flag temp bignum-widetag
(1+ bignum-digits-offset
))
190 (storew x y bignum-digits-offset other-pointer-lowtag
))
192 (define-move-vop move-from-signed
:move
193 (signed-reg) (descriptor-reg))
195 ;;; Check for fixnum, and possibly allocate one or two word bignum
196 ;;; result. Use a worst-case cost to make sure people know they may
197 ;;; be number consing.
198 (define-vop (move-from-unsigned)
199 (:args
(arg :scs
(signed-reg unsigned-reg
) :target x
))
200 (:results
(y :scs
(any-reg descriptor-reg
)))
201 (:temporary
(:scs
(non-descriptor-reg) :from
(:argument
0)) x temp
)
202 (:temporary
(:sc non-descriptor-reg
:offset nl3-offset
) pa-flag
)
203 (:note
"unsigned word to integer coercion")
206 (let ((done (gen-label))
207 (one-word (gen-label)))
208 (inst srawi. temp x n-positive-fixnum-bits
)
209 (inst slwi y x n-fixnum-tag-bits
)
212 (with-fixed-allocation
213 (y pa-flag temp bignum-widetag
(+ 2 bignum-digits-offset
))
215 (inst li temp
(logior (ash 1 n-widetag-bits
) bignum-widetag
))
217 (inst li temp
(logior (ash 2 n-widetag-bits
) bignum-widetag
))
218 (emit-label one-word
)
219 (storew temp y
0 other-pointer-lowtag
)
220 (storew x y bignum-digits-offset other-pointer-lowtag
))
222 (define-move-vop move-from-unsigned
:move
223 (unsigned-reg) (descriptor-reg))
226 ;;; Move untagged numbers.
227 (define-vop (word-move)
229 :scs
(signed-reg unsigned-reg
)
230 :load-if
(not (location= x y
))))
231 (:results
(y :scs
(signed-reg unsigned-reg
)
232 :load-if
(not (location= x y
))))
235 (:note
"word integer move")
238 (define-move-vop word-move
:move
239 (signed-reg unsigned-reg
) (signed-reg unsigned-reg
))
242 ;;; Move untagged number arguments/return-values.
243 (define-vop (move-word-arg)
245 :scs
(signed-reg unsigned-reg
))
247 :load-if
(not (sc-is y signed-reg unsigned-reg
))))
249 (:note
"word integer argument move")
252 ((signed-reg unsigned-reg
)
254 ((signed-stack unsigned-stack
)
255 (storew x fp
(tn-offset y
))))))
256 (define-move-vop move-word-arg
:move-arg
257 (descriptor-reg any-reg signed-reg unsigned-reg
) (signed-reg unsigned-reg
))
259 ;;; Use standard MOVE-ARG + coercion to move an untagged number to a
260 ;;; descriptor passing location.
261 (define-move-vop move-arg
:move-arg
262 (signed-reg unsigned-reg
) (any-reg descriptor-reg
))