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
)))))
72 (define-vop (fun-subtype)
73 (:translate fun-subtype
)
75 (:args
(function :scs
(descriptor-reg)))
76 (:results
(result :scs
(unsigned-reg)))
77 (:result-types positive-fixnum
)
79 (load-type result function
(- fun-pointer-lowtag
))))
81 (define-vop (set-fun-subtype)
82 (:translate
(setf fun-subtype
))
84 (:args
(type :scs
(unsigned-reg) :target result
)
85 (function :scs
(descriptor-reg)))
86 (:arg-types positive-fixnum
*)
87 (:results
(result :scs
(unsigned-reg)))
88 (:result-types positive-fixnum
)
90 (inst strb type
(@ function
(- (ecase *backend-byte-order
*
92 (:big-endian
(1- n-word-bytes
)))
96 (define-vop (get-header-data)
97 (:translate get-header-data
)
99 (:args
(x :scs
(descriptor-reg)))
100 (:results
(res :scs
(unsigned-reg)))
101 (:result-types positive-fixnum
)
103 (loadw res x
0 other-pointer-lowtag
)
104 (inst mov res
(lsr res n-widetag-bits
))))
106 (define-vop (get-closure-length)
107 (:translate get-closure-length
)
109 (:args
(x :scs
(descriptor-reg)))
110 (:results
(res :scs
(unsigned-reg)))
111 (:result-types positive-fixnum
)
113 (loadw res x
0 fun-pointer-lowtag
)
114 (inst mov res
(lsr res n-widetag-bits
))))
116 (define-vop (set-header-data)
117 (:translate set-header-data
)
119 (:args
(x :scs
(descriptor-reg) :target res
)
120 (data :scs
(any-reg immediate
)))
121 (:arg-types
* positive-fixnum
)
122 (:results
(res :scs
(descriptor-reg)))
123 (:temporary
(:scs
(non-descriptor-reg)) t1
)
125 (load-type t1 x
(- other-pointer-lowtag
))
128 (inst orr t1 t1
(lsl data
(- n-widetag-bits n-fixnum-tag-bits
))))
130 ;; FIXME: This will break if DATA has bits spread over more
131 ;; than an eight bit range aligned on an even bit position.
132 ;; See SYS:SRC;COMPILER;ARM;MOVE.LISP for a partial fix... And
133 ;; maybe it should be promoted to an instruction-macro?
134 (inst orr t1 t1
(ash (tn-value data
) n-widetag-bits
))))
135 (storew t1 x
0 other-pointer-lowtag
)
139 (define-vop (pointer-hash)
140 (:translate pointer-hash
)
141 (:args
(ptr :scs
(any-reg descriptor-reg
)))
142 (:results
(res :scs
(any-reg descriptor-reg
)))
145 (inst bic res ptr lowtag-mask
)
146 (inst mov res
(lsr res
1))))
150 (define-vop (dynamic-space-free-pointer)
151 (:results
(int :scs
(sap-reg)))
152 (:result-types system-area-pointer
)
153 (:translate dynamic-space-free-pointer
)
156 (load-symbol-value int
*allocation-pointer
*)))
158 (define-vop (binding-stack-pointer-sap)
159 (:results
(int :scs
(sap-reg)))
160 (:result-types system-area-pointer
)
161 (:translate binding-stack-pointer-sap
)
164 (load-symbol-value int
*binding-stack-pointer
*)))
166 (define-vop (control-stack-pointer-sap)
167 (:results
(int :scs
(sap-reg)))
168 (:result-types system-area-pointer
)
169 (:translate control-stack-pointer-sap
)
174 ;;;; Code object frobbing.
176 (define-vop (code-instructions)
177 (:translate code-instructions
)
179 (:args
(code :scs
(descriptor-reg)))
180 (:temporary
(:scs
(non-descriptor-reg)) ndescr
)
181 (:results
(sap :scs
(sap-reg)))
182 (:result-types system-area-pointer
)
184 (loadw ndescr code
0 other-pointer-lowtag
)
185 ;; CODE-HEADER-WIDETAG is #x38, which has the top two bits clear,
186 ;; so we don't to clear the low bits here. If we do, use BIC.
187 (inst mov ndescr
(lsr ndescr
(- n-widetag-bits word-shift
)))
188 (inst sub ndescr ndescr other-pointer-lowtag
)
189 (inst add sap code ndescr
)))
191 (define-vop (compute-fun)
192 (:args
(code :scs
(descriptor-reg))
193 (offset :scs
(signed-reg unsigned-reg
)))
194 (:arg-types
* positive-fixnum
)
195 (:results
(func :scs
(descriptor-reg)))
196 (:temporary
(:scs
(non-descriptor-reg)) ndescr
)
198 (loadw ndescr code
0 other-pointer-lowtag
)
199 ;; CODE-HEADER-WIDETAG is #x38, which has the top two bits clear,
200 ;; so we don't to clear the low bits here. If we do, use BIC.
201 (inst add ndescr offset
(lsr ndescr
(- n-widetag-bits word-shift
)))
202 (inst sub ndescr ndescr
(- other-pointer-lowtag fun-pointer-lowtag
))
203 (inst add func code ndescr
)))
205 ;;;; other miscellaneous VOPs
207 (defknown sb
!unix
::receive-pending-interrupt
() (values))
208 (define-vop (sb!unix
::receive-pending-interrupt
)
210 (:translate sb
!unix
::receive-pending-interrupt
)
213 (inst byte pending-interrupt-trap
)
214 (emit-alignment word-shift
)))
217 (:temporary
(:sc non-descriptor-reg
:offset ocfp-offset
) error-temp
)
219 ;; See macros.lisp, EMIT-ERROR-BREAK, for an explanation.
220 (inst mov error-temp
#x000f0000
)
221 (inst add error-temp error-temp
1)
223 (inst byte halt-trap
)
224 ;; Re-align to the next instruction boundary.
225 (emit-alignment word-shift
)))
227 ;;;; Dummy definition for a spin-loop hint VOP
228 (define-vop (spin-loop-hint)
229 (:translate spin-loop-hint
)