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 ;; FIXME: Using LDRB here would save us an instruction.
126 (loadw t1 x
0 other-pointer-lowtag
)
127 (inst and t1 t1 widetag-mask
)
130 (inst orr t1 t1
(lsl data
(- n-widetag-bits n-fixnum-tag-bits
))))
132 ;; FIXME: This will break if DATA has bits spread over more
133 ;; than an eight bit range aligned on an even bit position.
134 ;; See SYS:SRC;COMPILER;ARM;MOVE.LISP for a partial fix... And
135 ;; maybe it should be promoted to an instruction-macro?
136 (inst orr t1 t1
(ash (tn-value data
) n-widetag-bits
))))
137 (storew t1 x
0 other-pointer-lowtag
)
141 (define-vop (pointer-hash)
142 (:translate pointer-hash
)
143 (:args
(ptr :scs
(any-reg descriptor-reg
)))
144 (:results
(res :scs
(any-reg descriptor-reg
)))
147 (inst bic res ptr lowtag-mask
)
148 (inst mov res
(lsr res
1))))
152 (define-vop (dynamic-space-free-pointer)
153 (:results
(int :scs
(sap-reg)))
154 (:result-types system-area-pointer
)
155 (:translate dynamic-space-free-pointer
)
158 (load-symbol-value int
*allocation-pointer
*)))
160 (define-vop (binding-stack-pointer-sap)
161 (:results
(int :scs
(sap-reg)))
162 (:result-types system-area-pointer
)
163 (:translate binding-stack-pointer-sap
)
166 (load-symbol-value int
*binding-stack-pointer
*)))
168 (define-vop (control-stack-pointer-sap)
169 (:results
(int :scs
(sap-reg)))
170 (:result-types system-area-pointer
)
171 (:translate control-stack-pointer-sap
)
176 ;;;; Code object frobbing.
178 (define-vop (code-instructions)
179 (:translate code-instructions
)
181 (:args
(code :scs
(descriptor-reg)))
182 (:temporary
(:scs
(non-descriptor-reg)) ndescr
)
183 (:results
(sap :scs
(sap-reg)))
184 (:result-types system-area-pointer
)
186 (loadw ndescr code
0 other-pointer-lowtag
)
187 ;; CODE-HEADER-WIDETAG is #x38, which has the top two bits clear,
188 ;; so we don't to clear the low bits here. If we do, use BIC.
189 (inst mov ndescr
(lsr ndescr
(- n-widetag-bits word-shift
)))
190 (inst sub ndescr ndescr other-pointer-lowtag
)
191 (inst add sap code ndescr
)))
193 (define-vop (compute-fun)
194 (:args
(code :scs
(descriptor-reg))
195 (offset :scs
(signed-reg unsigned-reg
)))
196 (:arg-types
* positive-fixnum
)
197 (:results
(func :scs
(descriptor-reg)))
198 (:temporary
(:scs
(non-descriptor-reg)) ndescr
)
200 (loadw ndescr code
0 other-pointer-lowtag
)
201 ;; CODE-HEADER-WIDETAG is #x38, which has the top two bits clear,
202 ;; so we don't to clear the low bits here. If we do, use BIC.
203 (inst add ndescr offset
(lsr ndescr
(- n-widetag-bits word-shift
)))
204 (inst sub ndescr ndescr
(- other-pointer-lowtag fun-pointer-lowtag
))
205 (inst add func code ndescr
)))
207 ;;;; other miscellaneous VOPs
210 (:temporary
(:sc non-descriptor-reg
:offset ocfp-offset
) error-temp
)
212 ;; See macros.lisp, EMIT-ERROR-BREAK, for an explanation.
213 (inst mov error-temp
#x000f0000
)
214 (inst add error-temp error-temp
1)
216 (inst byte halt-trap
)
217 ;; Re-align to the next instruction boundary.
218 (emit-alignment word-shift
)))
220 ;;;; Dummy definition for a spin-loop hint VOP
221 (define-vop (spin-loop-hint)
222 (:translate spin-loop-hint
)