1 ;;;; ARM VM definitions of various system hacking operations
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 ;;;; Type frobbing VOPs
16 (define-vop (lowtag-of)
17 (:translate lowtag-of
)
19 (:args
(object :scs
(any-reg descriptor-reg
)))
20 (:results
(result :scs
(unsigned-reg)))
21 (:result-types positive-fixnum
)
23 (inst and result object lowtag-mask
)))
25 (define-vop (widetag-of)
26 (:translate widetag-of
)
28 (:args
(object :scs
(descriptor-reg) :to
(:eval
1)))
29 (:results
(result :scs
(unsigned-reg) :from
(:eval
0)))
30 (:result-types positive-fixnum
)
32 ;; First, pick off the immediate types, starting with FIXNUM.
33 (inst ands result object fixnum-tag-mask
)
34 ;; If it wasn't a fixnum, start with the full widetag.
35 (inst and
:ne result object widetag-mask
)
37 ;; Now, we have our result for an immediate type, but we might
38 ;; have a pointer object instead, in which case we need to do more
39 ;; work. Check for a pointer type.
41 ;; KLUDGE: We're a 32-bit port, so all pointer lowtags have the
42 ;; low bit set, but there's no obvious named constant for this.
43 ;; On 64-bit ports, all pointer lowtags have the low two bits set,
44 ;; so this wouldn't work as easily.
47 ;; If we have a pointer type, we need to compute a different
48 ;; answer. For lists and instances, we just need the lowtag. For
49 ;; functions and "other", we need to load the widetag from the
50 ;; object header. In both cases, having just the widetag
51 ;; available is handy.
52 (inst and
:ne result object lowtag-mask
)
54 ;; We now have the correct answer for list-pointer-lowtag and
55 ;; instance-pointer-lowtag, but need to pick off the case for the
56 ;; other two pointer types. KLUDGE: FUN-POINTER-LOWTAG and
57 ;; OTHER-POINTER-LOWTAG are both in the upper half of the lowtag
58 ;; space, while LIST-POINTER-LOWTAG and INSTANCE-POINTER-LOWTAG
59 ;; are in the lower half, so we distinguish with a bit test.
60 (inst tst
:ne object
4)
62 ;; We can't use both register and immediate offsets in the same
63 ;; load/store instruction, so we need to bias our register offset
64 ;; on big-endian systems.
65 (when (eq *backend-byte-order
* :big-endian
)
66 (inst sub
:ne result
(1- n-word-bytes
)))
68 ;; And, finally, pick out the widetag from the header.
69 (inst ldrb
:ne result
(@ object
(- result
)))))
71 (define-vop (%other-pointer-widetag
)
72 (:translate %other-pointer-widetag
)
74 (:args
(object :scs
(descriptor-reg)))
75 (:results
(result :scs
(unsigned-reg)))
76 (:result-types positive-fixnum
)
78 (load-type result object
(- other-pointer-lowtag
))))
80 (define-vop (fun-subtype)
81 (:translate fun-subtype
)
83 (:args
(function :scs
(descriptor-reg)))
84 (:results
(result :scs
(unsigned-reg)))
85 (:result-types positive-fixnum
)
87 (load-type result function
(- fun-pointer-lowtag
))))
89 (define-vop (set-fun-subtype)
90 (:translate
(setf fun-subtype
))
92 (:args
(type :scs
(unsigned-reg) :target result
)
93 (function :scs
(descriptor-reg)))
94 (:arg-types positive-fixnum
*)
95 (:results
(result :scs
(unsigned-reg)))
96 (:result-types positive-fixnum
)
98 (inst strb type
(@ function
(- (ecase *backend-byte-order
*
100 (:big-endian
(1- n-word-bytes
)))
101 fun-pointer-lowtag
)))
104 (define-vop (get-header-data)
105 (:translate get-header-data
)
107 (:args
(x :scs
(descriptor-reg)))
108 (:results
(res :scs
(unsigned-reg)))
109 (:result-types positive-fixnum
)
111 (loadw res x
0 other-pointer-lowtag
)
112 (inst mov res
(lsr res n-widetag-bits
))))
114 (define-vop (get-closure-length)
115 (:translate get-closure-length
)
117 (:args
(x :scs
(descriptor-reg)))
118 (:results
(res :scs
(unsigned-reg)))
119 (:result-types positive-fixnum
)
121 (loadw res x
0 fun-pointer-lowtag
)
122 (inst mov res
(lsr res n-widetag-bits
))))
124 (define-vop (set-header-data)
125 (:translate set-header-data
)
127 (:args
(x :scs
(descriptor-reg) :target res
)
128 (data :scs
(any-reg immediate
)))
129 (:arg-types
* positive-fixnum
)
130 (:results
(res :scs
(descriptor-reg)))
131 (:temporary
(:scs
(non-descriptor-reg)) t1
)
133 (load-type t1 x
(- other-pointer-lowtag
))
136 (inst orr t1 t1
(lsl data
(- n-widetag-bits n-fixnum-tag-bits
))))
138 ;; FIXME: This will break if DATA has bits spread over more
139 ;; than an eight bit range aligned on an even bit position.
140 ;; See SYS:SRC;COMPILER;ARM;MOVE.LISP for a partial fix... And
141 ;; maybe it should be promoted to an instruction-macro?
142 (inst orr t1 t1
(ash (tn-value data
) n-widetag-bits
))))
143 (storew t1 x
0 other-pointer-lowtag
)
147 (define-vop (pointer-hash)
148 (:translate pointer-hash
)
149 (:args
(ptr :scs
(any-reg descriptor-reg
)))
150 (:results
(res :scs
(any-reg descriptor-reg
)))
153 (inst bic res ptr lowtag-mask
)
154 (inst mov res
(lsr res
1))))
158 (define-vop (dynamic-space-free-pointer)
159 (:results
(int :scs
(sap-reg)))
160 (:result-types system-area-pointer
)
161 (:translate dynamic-space-free-pointer
)
164 (load-symbol-value int
*allocation-pointer
*)))
166 (define-vop (binding-stack-pointer-sap)
167 (:results
(int :scs
(sap-reg)))
168 (:result-types system-area-pointer
)
169 (:translate binding-stack-pointer-sap
)
172 (load-symbol-value int
*binding-stack-pointer
*)))
174 (define-vop (control-stack-pointer-sap)
175 (:results
(int :scs
(sap-reg)))
176 (:result-types system-area-pointer
)
177 (:translate control-stack-pointer-sap
)
182 ;;;; Code object frobbing.
184 (define-vop (code-instructions)
185 (:translate code-instructions
)
187 (:args
(code :scs
(descriptor-reg)))
188 (:temporary
(:scs
(non-descriptor-reg)) ndescr
)
189 (:results
(sap :scs
(sap-reg)))
190 (:result-types system-area-pointer
)
192 (loadw ndescr code
0 other-pointer-lowtag
)
193 ;; CODE-HEADER-WIDETAG is #x38, which has the top two bits clear,
194 ;; so we don't to clear the low bits here. If we do, use BIC.
195 (inst mov ndescr
(lsr ndescr
(- n-widetag-bits word-shift
)))
196 (inst sub ndescr ndescr other-pointer-lowtag
)
197 (inst add sap code ndescr
)))
199 (define-vop (compute-fun)
200 (:args
(code :scs
(descriptor-reg))
201 (offset :scs
(signed-reg unsigned-reg
)))
202 (:arg-types
* positive-fixnum
)
203 (:results
(func :scs
(descriptor-reg)))
204 (:temporary
(:scs
(non-descriptor-reg)) ndescr
)
206 (loadw ndescr code
0 other-pointer-lowtag
)
207 ;; CODE-HEADER-WIDETAG is #x38, which has the top two bits clear,
208 ;; so we don't to clear the low bits here. If we do, use BIC.
209 (inst add ndescr offset
(lsr ndescr
(- n-widetag-bits word-shift
)))
210 (inst sub ndescr ndescr
(- other-pointer-lowtag fun-pointer-lowtag
))
211 (inst add func code ndescr
)))
214 (define-vop (symbol-info-vector)
216 (:translate symbol-info-vector
)
217 (:args
(x :scs
(descriptor-reg)))
218 (:results
(res :scs
(descriptor-reg)))
219 (:temporary
(:sc unsigned-reg
) temp
)
221 (loadw res x symbol-info-slot other-pointer-lowtag
)
222 ;; If RES has list-pointer-lowtag, take its CDR. If not, use it as-is.
223 (inst and temp res lowtag-mask
)
224 (inst cmp temp list-pointer-lowtag
)
225 (loadw res res cons-cdr-slot list-pointer-lowtag
:eq
)))
228 (define-vop (symbol-plist)
230 (:translate symbol-plist
)
231 (:args
(x :scs
(descriptor-reg)))
232 (:results
(res :scs
(descriptor-reg)))
234 (loadw res x symbol-info-slot other-pointer-lowtag
)
235 ;; Instruction pun: (CAR x) is the same as (VECTOR-LENGTH x)
236 ;; so if the info slot holds a vector, this gets a fixnum- it's not a plist.
237 (loadw res res cons-car-slot list-pointer-lowtag
)
238 (inst tst res fixnum-tag-mask
)
239 (inst mov
:eq res null-tn
)))
241 ;;;; other miscellaneous VOPs
243 (defknown sb
!unix
::receive-pending-interrupt
() (values))
244 (define-vop (sb!unix
::receive-pending-interrupt
)
246 (:translate sb
!unix
::receive-pending-interrupt
)
249 (inst byte pending-interrupt-trap
)
250 (emit-alignment word-shift
)))
253 (:temporary
(:sc non-descriptor-reg
:offset ocfp-offset
) error-temp
)
255 ;; See macros.lisp, EMIT-ERROR-BREAK, for an explanation.
256 (inst mov error-temp
#x000f0000
)
257 (inst add error-temp error-temp
1)
259 (inst byte halt-trap
)
260 ;; Re-align to the next instruction boundary.
261 (emit-alignment word-shift
)))
263 ;;;; Dummy definition for a spin-loop hint VOP
264 (define-vop (spin-loop-hint)
265 (:translate spin-loop-hint
)