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
)
30 (define-move-fun (load-number 1) (vop x y
)
32 (signed-reg unsigned-reg
))
33 (let ((x (tn-value x
)))
34 (inst li
(if (>= x
(ash 1 31)) (logior (ash -
1 32) x
) x
) y
)))
36 (define-move-fun (load-character 1) (vop x y
)
37 ((immediate) (character-reg))
38 (inst li
(char-code (tn-value x
)) y
))
40 (define-move-fun (load-system-area-pointer 1) (vop x y
)
41 ((immediate) (sap-reg))
42 (inst li
(sap-int (tn-value x
)) y
))
44 (define-move-fun (load-constant 5) (vop x y
)
45 ((constant) (descriptor-reg))
46 (loadw y code-tn
(tn-offset x
) other-pointer-lowtag
))
48 (define-move-fun (load-stack 5) (vop x y
)
49 ((control-stack) (any-reg descriptor-reg
))
52 (define-move-fun (load-number-stack 5) (vop x y
)
53 ((character-stack) (character-reg)
55 (signed-stack) (signed-reg)
56 (unsigned-stack) (unsigned-reg))
57 (let ((nfp (current-nfp-tn vop
)))
58 (loadw y nfp
(tn-offset x
))))
60 (define-move-fun (store-stack 5) (vop x y
)
61 ((any-reg descriptor-reg
) (control-stack))
64 (define-move-fun (store-number-stack 5) (vop x y
)
65 ((character-reg) (character-stack)
67 (signed-reg) (signed-stack)
68 (unsigned-reg) (unsigned-stack))
69 (let ((nfp (current-nfp-tn vop
)))
70 (storew x nfp
(tn-offset y
))))
76 :scs
(any-reg descriptor-reg
)
77 :load-if
(not (location= x y
))))
78 (:results
(y :scs
(any-reg descriptor-reg
)
79 :load-if
(not (location= x y
))))
85 (define-move-vop move
:move
86 (any-reg descriptor-reg
)
87 (any-reg descriptor-reg
))
89 ;;; Make MOVE the check VOP for T so that type check generation
90 ;;; doesn't think it is a hairy type. This also allows checking of a
91 ;;; few of the values in a continuation to fall out.
92 (primitive-type-vop move
(:check
) t
)
94 ;;; The MOVE-ARG VOP is used for moving descriptor values into another
95 ;;; frame for argument or known value passing.
96 (define-vop (move-arg)
98 :scs
(any-reg descriptor-reg
))
100 :load-if
(not (sc-is y any-reg descriptor-reg
))))
104 ((any-reg descriptor-reg
)
107 (storew x fp
(tn-offset y
))))))
108 (define-move-vop move-arg
:move-arg
109 (any-reg descriptor-reg
)
110 (any-reg descriptor-reg
))
116 ;;; This VOP exists just to begin the lifetime of a TN that couldn't
117 ;;; be written legally due to a type error. An error is signalled
118 ;;; before this VOP is so we don't need to do anything (not that there
119 ;;; would be anything sensible to do anyway.)
120 (define-vop (illegal-move)
125 (:save-p
:compute-only
)
127 (error-call vop object-not-type-error x type
)))
129 ;;;; Moves and coercions:
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.
135 ;;; ARG is a fixnum, so just shift it. We need a type restriction
136 ;;; because some possible arg SCs (control-stack) overlap with
137 ;;; possible bignum arg SCs.
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")
145 (define-move-vop move-to-word
/fixnum
:move
146 (any-reg descriptor-reg
) (signed-reg unsigned-reg
))
148 ;;; ARG is a non-immediate constant, load it.
149 (define-vop (move-to-word-c)
150 (:args
(x :scs
(constant)))
151 (:results
(y :scs
(signed-reg unsigned-reg
)))
152 (:note
"constant load")
154 (inst li
(tn-value x
) y
)))
155 (define-move-vop move-to-word-c
:move
156 (constant) (signed-reg unsigned-reg
))
158 ;;; ARG is a fixnum or bignum, figure out which and load if necessary.
159 (define-vop (move-to-word/integer
)
160 (:args
(x :scs
(descriptor-reg)))
161 (:results
(y :scs
(signed-reg unsigned-reg
)))
162 (:note
"integer to untagged word coercion")
164 (inst extru x
31 2 zero-tn
:<>)
166 (loadw y x bignum-digits-offset other-pointer-lowtag
)))
167 (define-move-vop move-to-word
/integer
:move
168 (descriptor-reg) (signed-reg unsigned-reg
))
170 ;;; RESULT is a fixnum, so we can just shift. We need the result type
171 ;;; restriction because of the control-stack ambiguity noted above.
172 (define-vop (move-from-word/fixnum
)
173 (:args
(x :scs
(signed-reg unsigned-reg
)))
174 (:results
(y :scs
(any-reg descriptor-reg
)))
175 (:result-types tagged-num
)
176 (:note
"fixnum tagging")
179 (define-move-vop move-from-word
/fixnum
:move
180 (signed-reg unsigned-reg
) (any-reg descriptor-reg
))
182 ;;; RESULT may be a bignum, so we have to check. Use a worst-case
183 ;;; cost to make sure people know they may be number consing.
184 (define-vop (move-from-signed)
185 (:args
(x :scs
(signed-reg unsigned-reg
) :to
(:eval
1)))
186 (:results
(y :scs
(any-reg descriptor-reg
) :from
(:eval
0)))
187 (:temporary
(:scs
(non-descriptor-reg)) temp
)
188 (:note
"signed word to integer coercion")
190 ;; Extract the top three bits.
191 (inst extrs x
2 3 temp
:=)
192 ;; Invert them (unless they are already zero).
193 (inst uaddcm zero-tn temp temp
)
194 ;; If we are left with zero, it will fit in a fixnum. So branch around
195 ;; the bignum-construction, doing the shift in the delay slot.
196 (inst comb
:= temp zero-tn done
)
198 ;; Make a single-digit bignum.
199 (with-fixed-allocation (y temp bignum-widetag
(1+ bignum-digits-offset
))
200 (storew x y bignum-digits-offset other-pointer-lowtag
))
202 (define-move-vop move-from-signed
:move
203 (signed-reg) (descriptor-reg))
205 ;;; Check for fixnum, and possibly allocate one or two word bignum
206 ;;; result. Use a worst-case cost to make sure people know they may
207 ;;; be number consing.
208 (define-vop (move-from-unsigned)
209 (:args
(x :scs
(signed-reg unsigned-reg
) :to
(:eval
1)))
210 (:results
(y :scs
(any-reg descriptor-reg
) :from
(:eval
0)))
211 (:temporary
(:scs
(non-descriptor-reg)) temp
)
212 (:note
"unsigned word to integer coercion")
214 ;; Grab the top three bits.
215 (inst extrs x
2 3 temp
)
216 ;; If zero, it will fit as a fixnum.
217 (inst comib
:= 0 temp done
)
220 (pseudo-atomic (:extra
(pad-data-block (1+ bignum-digits-offset
)))
221 ;; Create the result pointer.
222 (inst move alloc-tn y
)
223 (inst dep other-pointer-lowtag
31 3 y
)
224 ;; Check the high bit, and skip the next instruction if it's 0.
225 (inst comclr x zero-tn zero-tn
:>=)
226 ;; The high bit is set, so allocate enough space for a two-word bignum.
227 ;; We always skip the following instruction, so it is only executed
228 ;; when we want one word.
229 (inst addi
(pad-data-block 1) alloc-tn alloc-tn
:tr
)
230 ;; Set up the header for one word. Use ADDI instead of LI so we can
231 ;; skip the next instruction.
232 (inst addi
(logior (ash 1 n-widetag-bits
) bignum-widetag
) zero-tn temp
:tr
)
233 ;; Set up the header for two words.
234 (inst li
(logior (ash 2 n-widetag-bits
) bignum-widetag
) temp
)
235 ;; Store the header and the data.
236 (storew temp y
0 other-pointer-lowtag
)
237 (storew x y bignum-digits-offset other-pointer-lowtag
))
239 (define-move-vop move-from-unsigned
:move
240 (unsigned-reg) (descriptor-reg))
242 ;;; Move untagged numbers.
243 (define-vop (word-move)
245 :scs
(signed-reg unsigned-reg
)
246 :load-if
(not (location= x y
))))
247 (:results
(y :scs
(signed-reg unsigned-reg
)
248 :load-if
(not (location= x y
))))
251 (:note
"word integer move")
254 (define-move-vop word-move
:move
255 (signed-reg unsigned-reg
) (signed-reg unsigned-reg
))
257 ;;; Move untagged number args/return-values.
258 (define-vop (move-word-arg)
260 :scs
(signed-reg unsigned-reg
))
262 :load-if
(not (sc-is y sap-reg
))))
264 (:note
"word integer argument move")
267 ((signed-reg unsigned-reg
)
269 ((signed-stack unsigned-stack
)
270 (storew x fp
(tn-offset y
))))))
271 (define-move-vop move-word-arg
:move-arg
272 (descriptor-reg any-reg signed-reg unsigned-reg
) (signed-reg unsigned-reg
))
274 ;;; Use standard MOVE-ARG + coercion to move an untagged number to a
275 ;;; descriptor passing location.
276 (define-move-vop move-arg
:move-arg
277 (signed-reg unsigned-reg
) (any-reg descriptor-reg
))