1 ;;;; PPC 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 andi. 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
)
33 (inst andi. result object lowtag-mask
)
34 ;; Check for various pointer types.
35 (inst cmpwi result list-pointer-lowtag
)
37 (inst cmpwi result other-pointer-lowtag
)
38 (inst beq other-pointer
)
39 (inst cmpwi result fun-pointer-lowtag
)
40 (inst beq function-pointer
)
41 (inst cmpwi result instance-pointer-lowtag
)
43 ;; Okay, it is an immediate. If fixnum, we want zero. Otherwise,
44 ;; we want the low 8 bits.
45 (inst andi. result object fixnum-tag-mask
)
47 ;; It wasn't a fixnum, so get the low 8 bits.
48 (inst andi. result object widetag-mask
)
52 (load-type result object
(- fun-pointer-lowtag
))
56 (load-type result object
(- other-pointer-lowtag
))
61 (define-vop (fun-subtype)
62 (:translate fun-subtype
)
64 (:args
(function :scs
(descriptor-reg)))
65 (:results
(result :scs
(unsigned-reg)))
66 (:result-types positive-fixnum
)
68 (load-type result function
(- fun-pointer-lowtag
))))
70 (define-vop (set-fun-subtype)
71 (:translate
(setf fun-subtype
))
73 (:args
(type :scs
(unsigned-reg) :target result
)
74 (function :scs
(descriptor-reg)))
75 (:arg-types positive-fixnum
*)
76 (:results
(result :scs
(unsigned-reg)))
77 (:result-types positive-fixnum
)
79 (inst stb type function
(- 3 fun-pointer-lowtag
))
82 (define-vop (get-header-data)
83 (:translate get-header-data
)
85 (:args
(x :scs
(descriptor-reg)))
86 (:results
(res :scs
(unsigned-reg)))
87 (:result-types positive-fixnum
)
89 (loadw res x
0 other-pointer-lowtag
)
90 (inst srwi res res n-widetag-bits
)))
92 (define-vop (get-closure-length)
93 (:translate get-closure-length
)
95 (:args
(x :scs
(descriptor-reg)))
96 (:results
(res :scs
(unsigned-reg)))
97 (:result-types positive-fixnum
)
99 (loadw res x
0 fun-pointer-lowtag
)
100 (inst srwi res res n-widetag-bits
)))
102 (define-vop (set-header-data)
103 (:translate set-header-data
)
105 (:args
(x :scs
(descriptor-reg) :target res
)
106 (data :scs
(any-reg immediate zero
)))
107 (:arg-types
* positive-fixnum
)
108 (:results
(res :scs
(descriptor-reg)))
109 (:temporary
(:scs
(non-descriptor-reg)) t1 t2
)
111 (loadw t1 x
0 other-pointer-lowtag
)
112 (inst andi. t1 t1 widetag-mask
)
115 (inst slwi t2 data
(- n-widetag-bits n-fixnum-tag-bits
))
118 (inst ori t1 t1
(ash (tn-value data
) n-widetag-bits
)))
120 (storew t1 x
0 other-pointer-lowtag
)
124 (define-vop (pointer-hash)
125 (:translate pointer-hash
)
126 (:args
(ptr :scs
(any-reg descriptor-reg
)))
127 (:results
(res :scs
(any-reg descriptor-reg
)))
130 ;; FIXME: It would be better if this would mask the lowtag,
131 ;; and shift the result into a positive fixnum like on x86.
132 (inst rlwinm res ptr n-fixnum-tag-bits
1 n-positive-fixnum-bits
)))
137 (define-vop (dynamic-space-free-pointer)
138 (:results
(int :scs
(sap-reg)))
139 (:result-types system-area-pointer
)
140 (:translate dynamic-space-free-pointer
)
143 (move int alloc-tn
)))
145 (define-vop (binding-stack-pointer-sap)
146 (:results
(int :scs
(sap-reg)))
147 (:result-types system-area-pointer
)
148 (:translate binding-stack-pointer-sap
)
153 (define-vop (control-stack-pointer-sap)
154 (:results
(int :scs
(sap-reg)))
155 (:result-types system-area-pointer
)
156 (:translate control-stack-pointer-sap
)
162 ;;;; Code object frobbing.
164 (define-vop (code-instructions)
165 (:translate code-instructions
)
167 (:args
(code :scs
(descriptor-reg)))
168 (:temporary
(:scs
(non-descriptor-reg)) ndescr
)
169 (:results
(sap :scs
(sap-reg)))
170 (:result-types system-area-pointer
)
172 (loadw ndescr code
0 other-pointer-lowtag
)
173 (inst srwi ndescr ndescr n-widetag-bits
)
174 (inst slwi ndescr ndescr word-shift
)
175 (inst subi ndescr ndescr other-pointer-lowtag
)
176 (inst add sap code ndescr
)))
178 (define-vop (compute-fun)
179 (:args
(code :scs
(descriptor-reg))
180 (offset :scs
(signed-reg unsigned-reg
)))
181 (:arg-types
* positive-fixnum
)
182 (:results
(func :scs
(descriptor-reg)))
183 (:temporary
(:scs
(non-descriptor-reg)) ndescr
)
185 (loadw ndescr code
0 other-pointer-lowtag
)
186 (inst srwi ndescr ndescr n-widetag-bits
)
187 (inst slwi ndescr ndescr word-shift
)
188 (inst add ndescr ndescr offset
)
189 (inst addi ndescr ndescr
(- fun-pointer-lowtag other-pointer-lowtag
))
190 (inst add func code ndescr
)))
194 ;;;; Other random VOPs.
197 (defknown sb
!unix
::receive-pending-interrupt
() (values))
198 (define-vop (sb!unix
::receive-pending-interrupt
)
200 (:translate sb
!unix
::receive-pending-interrupt
)
202 (inst unimp pending-interrupt-trap
)))
205 (define-vop (insert-safepoint)
207 (:translate sb
!kernel
::gc-safepoint
)
212 (defknown current-thread-offset-sap
((unsigned-byte 64))
213 system-area-pointer
(flushable))
216 (define-vop (current-thread-offset-sap)
217 (:results
(sap :scs
(sap-reg)))
218 (:result-types system-area-pointer
)
219 (:translate current-thread-offset-sap
)
220 (:args
(n :scs
(unsigned-reg) :target sap
))
221 (:arg-types unsigned-num
)
224 (inst slwi n n word-shift
)
225 (inst lwzx sap thread-base-tn n
)))
229 (inst unimp halt-trap
)))
231 ;;;; Dynamic vop count collection support
233 (define-vop (count-me)
234 (:args
(count-vector :scs
(descriptor-reg)))
236 (:temporary
(:scs
(non-descriptor-reg)) count
)
239 (- (* (+ index vector-data-offset
) n-word-bytes
) other-pointer-lowtag
)))
240 (aver (typep offset
'(signed-byte 16)))
241 (inst lwz count count-vector offset
)
242 (inst addi count count
1)
243 (inst stw count count-vector offset
))))
245 ;;;; Memory barrier support
247 #!+memory-barrier-vops
248 (define-vop (%compiler-barrier
)
250 (:translate %compiler-barrier
)
253 #!+memory-barrier-vops
254 (define-vop (%memory-barrier
)
256 (:translate %memory-barrier
)
260 #!+memory-barrier-vops
261 (define-vop (%read-barrier
)
263 (:translate %read-barrier
)
267 #!+memory-barrier-vops
268 (define-vop (%write-barrier
)
270 (:translate %write-barrier
)
274 #!+memory-barrier-vops
275 (define-vop (%data-dependency-barrier
)
277 (:translate %data-dependency-barrier
)
280 ;;;; Dummy definition for a spin-loop hint VOP
281 (define-vop (spin-loop-hint)
282 (:translate spin-loop-hint
)