1 ;;;; the HPPA 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 zero immediate
)
16 (any-reg descriptor-reg
))
17 (let ((val (tn-value x
)))
20 (inst li
(fixnumize val
) y
))
26 (inst li
(logior (ash (char-code val
) n-widetag-bits
)
27 character-widetag
) y
)))))
29 (define-move-fun (load-number 1) (vop x y
)
31 (signed-reg unsigned-reg
))
32 (inst li
(tn-value x
) y
))
34 (define-move-fun (load-character 1) (vop x y
)
35 ((immediate) (character-reg))
36 (inst li
(char-code (tn-value x
)) y
))
38 (define-move-fun (load-system-area-pointer 1) (vop x y
)
39 ((immediate) (sap-reg))
40 (inst li
(sap-int (tn-value x
)) y
))
42 (define-move-fun (load-constant 5) (vop x y
)
43 ((constant) (descriptor-reg any-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 null zero
) (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 (unless (location= x y
)
83 ((any-reg descriptor-reg
)
86 (store-stack-tn y x
))))))
88 (define-move-vop move
:move
89 (any-reg descriptor-reg zero null
)
90 (any-reg descriptor-reg
))
92 ;;; Make MOVE the check VOP for T so that type check generation
93 ;;; doesn't think it is a hairy type. This also allows checking of a
94 ;;; few of the values in a continuation to fall out.
95 (primitive-type-vop move
(:check
) t
)
97 ;;; The MOVE-ARG VOP is used for moving descriptor values into another
98 ;;; frame for argument or known value passing.
99 (define-vop (move-arg)
101 :scs
(any-reg descriptor-reg null zero
))
103 :load-if
(not (sc-is y any-reg descriptor-reg
))))
107 ((any-reg descriptor-reg
)
110 (storew x fp
(tn-offset y
))))))
111 (define-move-vop move-arg
:move-arg
112 (any-reg descriptor-reg null zero
)
113 (any-reg descriptor-reg
))
118 ;;; This VOP exists just to begin the lifetime of a TN that couldn't
119 ;;; be written legally due to a type error. An error is signalled
120 ;;; before this VOP is so we don't need to do anything (not that there
121 ;;; would be anything sensible to do anyway.)
122 (define-vop (illegal-move)
127 (:save-p
:compute-only
)
129 (error-call vop object-not-type-error x type
)))
131 ;;;; Moves and coercions:
133 ;;; These MOVE-TO-WORD VOPs move a tagged integer to a raw full-word
134 ;;; representation. Similarly, the MOVE-FROM-WORD VOPs converts a raw integer
135 ;;; to a tagged bignum or fixnum.
137 ;;; ARG is a fixnum, so just shift it. We need a type restriction
138 ;;; because some possible arg SCs (control-stack) overlap with
139 ;;; possible bignum arg SCs.
140 (define-vop (move-to-word/fixnum
)
141 (:args
(x :scs
(any-reg descriptor-reg
)))
142 (:results
(y :scs
(signed-reg unsigned-reg
)))
143 (:arg-types tagged-num
)
144 (:note
"fixnum untagging")
146 (inst sra x n-fixnum-tag-bits y
)))
148 (define-move-vop move-to-word
/fixnum
:move
149 (any-reg descriptor-reg
) (signed-reg unsigned-reg
))
151 ;;; ARG is a non-immediate constant, load it.
152 (define-vop (move-to-word-c)
153 (:args
(x :scs
(constant)))
154 (:results
(y :scs
(signed-reg unsigned-reg
)))
155 (:note
"constant load")
157 (cond ((sb!c
::tn-leaf x
)
158 (inst li
(tn-value x
) y
))
160 (loadw y code-tn
(tn-offset x
) other-pointer-lowtag
)
161 (inst sra y n-fixnum-tag-bits y
)))))
163 (define-move-vop move-to-word-c
:move
164 (constant) (signed-reg unsigned-reg
))
166 ;;; ARG is a fixnum or bignum, figure out which and load if necessary.
167 (define-vop (move-to-word/integer
)
168 (:args
(x :scs
(descriptor-reg)))
169 (:results
(y :scs
(signed-reg unsigned-reg
)))
170 (:note
"integer to untagged word coercion")
173 (inst extru x
31 2 zero-tn
:=)
174 (loadw y x bignum-digits-offset other-pointer-lowtag
)))
176 (define-move-vop move-to-word
/integer
:move
177 (descriptor-reg) (signed-reg unsigned-reg
))
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 (define-vop (move-from-word/fixnum
)
182 (:args
(x :scs
(signed-reg unsigned-reg
)))
183 (:results
(y :scs
(any-reg descriptor-reg
)))
184 (:result-types tagged-num
)
185 (:note
"fixnum tagging")
189 (define-move-vop move-from-word
/fixnum
:move
190 (signed-reg unsigned-reg
) (any-reg descriptor-reg
))
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")
201 (let ((done (gen-label)))
202 ;; Extract the top three bits.
203 (inst extrs x
2 3 temp
:=)
204 ;; Invert them (unless they are already zero).
205 (inst uaddcm zero-tn temp temp
)
206 ;; If we are left with zero, it will fit in a fixnum. So branch around
207 ;; the bignum-construction, doing the shift in the delay slot.
208 (inst comb
:= temp zero-tn done
)
210 ;; Make a single-digit bignum.
211 (with-fixed-allocation
212 (y nil temp bignum-widetag
(1+ bignum-digits-offset
) nil
)
213 (storew x y bignum-digits-offset other-pointer-lowtag
))
216 (define-move-vop move-from-signed
:move
217 (signed-reg) (descriptor-reg))
219 ;;; Check for fixnum, and possibly allocate one or two word bignum
220 ;;; result. Use a worst-case cost to make sure people know they may
221 ;;; be number consing.
222 (define-vop (move-from-unsigned)
223 (:note
"unsigned word to integer coercion")
224 (:args
(arg :scs
(signed-reg unsigned-reg
) :target x
))
225 (:results
(y :scs
(any-reg descriptor-reg
)))
226 (:temporary
(:scs
(non-descriptor-reg) :from
(:argument
0)) x temp
)
230 (inst comb
:= temp zero-tn done
)
232 (pseudo-atomic (:extra
(pad-data-block (+ bignum-digits-offset
2)))
233 (set-lowtag other-pointer-lowtag alloc-tn y
)
234 (inst xor temp temp temp
)
235 (inst comclr x zero-tn zero-tn
:>=)
237 (inst sll temp n-widetag-bits temp
)
238 (inst addi
(logior (ash 1 n-widetag-bits
) bignum-widetag
) temp temp
)
239 (storew temp y
0 other-pointer-lowtag
))
241 (storew x y bignum-digits-offset other-pointer-lowtag
)
244 (define-move-vop move-from-unsigned
:move
245 (unsigned-reg) (descriptor-reg))
247 ;;; Move untagged numbers.
248 (define-vop (word-move)
250 :scs
(signed-reg unsigned-reg
)
251 :load-if
(not (location= x y
))))
252 (:results
(y :scs
(signed-reg unsigned-reg
)
253 :load-if
(not (location= x y
))))
256 (:note
"word integer move")
260 (define-move-vop word-move
:move
261 (signed-reg unsigned-reg
) (signed-reg unsigned-reg
))
263 ;;; Move untagged number args/return-values.
264 (define-vop (move-word-arg)
266 :scs
(signed-reg unsigned-reg
))
268 :load-if
(not (sc-is y sap-reg
))))
270 (:note
"word integer argument move")
273 ((signed-reg unsigned-reg
)
275 ((signed-stack unsigned-stack
)
276 (storew x fp
(tn-offset y
))))))
278 (define-move-vop move-word-arg
:move-arg
279 (descriptor-reg any-reg signed-reg unsigned-reg
) (signed-reg unsigned-reg
))
281 ;;; Use standard MOVE-ARG + coercion to move an untagged number to a
282 ;;; descriptor passing location.
283 (define-move-vop move-arg
:move-arg
284 (signed-reg unsigned-reg
) (any-reg descriptor-reg
))