1 ;;;; x86 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 control-stack
)
21 (:results
(result :scs
(unsigned-reg)))
22 (:result-types positive-fixnum
)
25 (inst and result lowtag-mask
)))
27 (define-vop (widetag-of)
28 (:translate widetag-of
)
30 (:args
(object :scs
(descriptor-reg)))
31 (:temporary
(:sc unsigned-reg
:offset eax-offset
:to
(:result
0)) eax
)
32 (:results
(result :scs
(unsigned-reg)))
33 (:result-types positive-fixnum
)
36 (inst and al-tn lowtag-mask
)
37 (inst cmp al-tn other-pointer-lowtag
)
38 (inst jmp
:e other-ptr
)
39 (inst cmp al-tn fun-pointer-lowtag
)
40 (inst jmp
:e function-ptr
)
42 ;; Pick off structures and list pointers.
47 (inst and al-tn fixnum-tag-mask
)
50 ;; must be an other immediate
55 (load-type al-tn object
(- fun-pointer-lowtag
))
59 (load-type al-tn object
(- other-pointer-lowtag
))
62 (inst movzx result al-tn
)))
64 (define-vop (fun-subtype)
65 (:translate fun-subtype
)
67 (:args
(function :scs
(descriptor-reg)))
68 (:temporary
(:sc byte-reg
:from
(:eval
0) :to
(:eval
1)) temp
)
69 (:results
(result :scs
(unsigned-reg)))
70 (:result-types positive-fixnum
)
72 (load-type temp function
(- fun-pointer-lowtag
))
73 (inst movzx result temp
)))
75 (define-vop (set-fun-subtype)
76 (:translate
(setf fun-subtype
))
78 (:args
(type :scs
(unsigned-reg) :target eax
)
79 (function :scs
(descriptor-reg)))
80 (:arg-types positive-fixnum
*)
81 (:temporary
(:sc unsigned-reg
:offset eax-offset
:from
(:argument
0)
82 :to
(:result
0) :target result
)
84 (:results
(result :scs
(unsigned-reg)))
85 (:result-types positive-fixnum
)
88 (storeb al-tn function
0 fun-pointer-lowtag
)
91 (define-vop (get-header-data)
92 (:translate get-header-data
)
94 (:args
(x :scs
(descriptor-reg)))
95 (:results
(res :scs
(unsigned-reg)))
96 (:result-types positive-fixnum
)
98 (loadw res x
0 other-pointer-lowtag
)
99 (inst shr res n-widetag-bits
)))
101 (define-vop (get-closure-length)
102 (:translate get-closure-length
)
104 (:args
(x :scs
(descriptor-reg)))
105 (:results
(res :scs
(unsigned-reg)))
106 (:result-types positive-fixnum
)
108 (loadw res x
0 fun-pointer-lowtag
)
109 (inst shr res n-widetag-bits
)))
111 (define-vop (set-header-data)
112 (:translate set-header-data
)
114 (:args
(x :scs
(descriptor-reg) :target res
:to
(:result
0))
115 (data :scs
(any-reg) :target eax
))
116 (:arg-types
* positive-fixnum
)
117 (:results
(res :scs
(descriptor-reg)))
118 (:temporary
(:sc unsigned-reg
:offset eax-offset
119 :from
(:argument
1) :to
(:result
0)) eax
)
122 (inst shl eax
(- n-widetag-bits
2))
123 (inst mov al-tn
(make-ea :byte
:base x
:disp
(- other-pointer-lowtag
)))
124 (storew eax x
0 other-pointer-lowtag
)
127 (define-vop (pointer-hash)
128 (:translate pointer-hash
)
129 (:args
(ptr :scs
(any-reg descriptor-reg
) :target res
))
130 (:results
(res :scs
(any-reg descriptor-reg
)))
134 ;; Mask the lowtag, and shift the whole address into a positive
136 (inst and res
(lognot lowtag-mask
))
139 (define-vop (make-other-immediate-type)
140 (:args
(val :scs
(any-reg descriptor-reg
) :target res
)
141 (type :scs
(unsigned-reg immediate
)))
142 (:results
(res :scs
(any-reg descriptor-reg
) :from
(:argument
0)))
145 (inst shl res
(- n-widetag-bits n-fixnum-tag-bits
))
146 (inst or res
(sc-case type
148 (immediate (tn-value type
))))))
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-binding-stack-pointer int
)))
168 (defknown (setf binding-stack-pointer-sap
)
169 (system-area-pointer) system-area-pointer
())
171 (define-vop (set-binding-stack-pointer-sap)
172 (:args
(new-value :scs
(sap-reg) :target int
))
173 (:arg-types system-area-pointer
)
174 (:results
(int :scs
(sap-reg)))
175 (:result-types system-area-pointer
)
176 (:translate
(setf binding-stack-pointer-sap
))
179 (store-binding-stack-pointer new-value
)
180 (move int new-value
)))
182 (define-vop (control-stack-pointer-sap)
183 (:results
(int :scs
(sap-reg)))
184 (:result-types system-area-pointer
)
185 (:translate control-stack-pointer-sap
)
190 ;;;; code object frobbing
192 (define-vop (code-instructions)
193 (:translate code-instructions
)
195 (:args
(code :scs
(descriptor-reg) :to
(:result
0)))
196 (:results
(sap :scs
(sap-reg) :from
(:argument
0)))
197 (:result-types system-area-pointer
)
199 (loadw sap code
0 other-pointer-lowtag
)
200 (inst shr sap n-widetag-bits
)
201 (inst lea sap
(make-ea :byte
:base code
:index sap
:scale
4
202 :disp
(- other-pointer-lowtag
)))))
204 (define-vop (compute-fun)
205 (:args
(code :scs
(descriptor-reg) :to
(:result
0))
206 (offset :scs
(signed-reg unsigned-reg
) :to
(:result
0)))
207 (:arg-types
* positive-fixnum
)
208 (:results
(func :scs
(descriptor-reg) :from
(:argument
0)))
210 (loadw func code
0 other-pointer-lowtag
)
211 (inst shr func n-widetag-bits
)
213 (make-ea :byte
:base offset
:index func
:scale
4
214 :disp
(- fun-pointer-lowtag other-pointer-lowtag
)))
215 (inst add func code
)))
217 (define-vop (%simple-fun-self
)
219 (:translate %simple-fun-self
)
220 (:args
(function :scs
(descriptor-reg)))
221 (:results
(result :scs
(descriptor-reg)))
223 (loadw result function simple-fun-self-slot fun-pointer-lowtag
)
225 (make-ea :byte
:base result
226 :disp
(- fun-pointer-lowtag
227 (* simple-fun-code-offset n-word-bytes
))))))
229 ;;; The closure function slot is a pointer to raw code on X86 instead
230 ;;; of a pointer to the code function object itself. This VOP is used
231 ;;; to reference the function object given the closure object.
232 (define-source-transform %closure-fun
(closure)
233 `(%simple-fun-self
,closure
))
235 (define-vop (%set-fun-self
)
237 (:translate
(setf %simple-fun-self
))
238 (:args
(new-self :scs
(descriptor-reg) :target result
:to
:result
)
239 (function :scs
(descriptor-reg) :to
:result
))
240 (:temporary
(:sc any-reg
:from
(:argument
0) :to
:result
) temp
)
241 (:results
(result :scs
(descriptor-reg)))
243 (inst lea temp
(make-ea-for-object-slot new-self simple-fun-code-offset
245 (storew temp function simple-fun-self-slot fun-pointer-lowtag
)
246 (move result new-self
)))
248 ;;;; other miscellaneous VOPs
250 (defknown sb
!unix
::receive-pending-interrupt
() (values))
251 (define-vop (sb!unix
::receive-pending-interrupt
)
253 (:translate sb
!unix
::receive-pending-interrupt
)
255 (inst break pending-interrupt-trap
)))
258 (defknown current-thread-offset-sap
((unsigned-byte 32))
259 system-area-pointer
(flushable))
262 (define-vop (current-thread-offset-sap)
263 (:results
(sap :scs
(sap-reg)))
264 (:result-types system-area-pointer
)
265 (:translate current-thread-offset-sap
)
266 (:args
(n :scs
(unsigned-reg) :target sap
))
267 (:arg-types unsigned-num
)
270 (inst mov sap
(make-ea :dword
:disp
0 :index n
:scale
4) :fs
)))
274 (inst break halt-trap
)))
276 (defknown float-wait
() (values))
277 (define-vop (float-wait)
279 (:translate float-wait
)
281 (:save-p
:compute-only
)
283 (note-next-instruction vop
:internal-error
)
288 ;;; the RDTSC instruction (present on Pentium processors and
289 ;;; successors) allows you to access the time-stamp counter, a 64-bit
290 ;;; model-specific register that counts executed cycles. The
291 ;;; instruction returns the low cycle count in EAX and high cycle
294 ;;; In order to obtain more significant results on out-of-order
295 ;;; processors (such as the Pentium II and later), we issue a
296 ;;; serializing CPUID instruction before reading the cycle counter.
297 ;;; This instruction is used for its side effect of emptying the
298 ;;; processor pipeline, to ensure that the RDTSC instruction is
299 ;;; executed once all pending instructions have been completed.
300 ;;; CPUID writes to EBX and ECX in addition to EAX and EDX, so
301 ;;; they need to be added as temporaries.
303 ;;; Note that cache effects mean that the cycle count can vary for
304 ;;; different executions of the same code (it counts cycles, not
305 ;;; retired instructions). Furthermore, the results are per-processor
306 ;;; and not per-process, so are unreliable on multiprocessor machines
307 ;;; where processes can migrate between processors.
309 ;;; This method of obtaining a cycle count has the advantage of being
310 ;;; very fast (around 20 cycles), and of not requiring a system call.
311 ;;; However, you need to know your processor's clock speed to translate
312 ;;; this into real execution time.
314 ;;; FIXME: This about the WITH-CYCLE-COUNTER interface a bit, and then
315 ;;; perhaps export it from SB-SYS.
317 (defknown %read-cycle-counter
() (values (unsigned-byte 32) (unsigned-byte 32)) ())
319 (define-vop (%read-cycle-counter
)
321 (:translate %read-cycle-counter
)
322 (:temporary
(:sc unsigned-reg
:offset eax-offset
:target lo
) eax
)
323 (:temporary
(:sc unsigned-reg
:offset edx-offset
:target hi
) edx
)
324 (:temporary
(:sc unsigned-reg
:offset ebx-offset
) ebx
)
325 (:temporary
(:sc unsigned-reg
:offset ecx-offset
) ecx
)
327 (:results
(hi :scs
(unsigned-reg))
328 (lo :scs
(unsigned-reg)))
329 (:result-types unsigned-num unsigned-num
)
332 ;; Intel docs seem quite consistent on only using CPUID before RDTSC,
333 ;; not both before and after. Go figure.
339 (defmacro with-cycle-counter
(&body body
)
340 "Returns the primary value of BODY as the primary value, and the
341 number of CPU cycles elapsed as secondary value. EXPERIMENTAL."
342 (with-unique-names (hi0 hi1 lo0 lo1
)
343 `(multiple-value-bind (,hi0
,lo0
) (%read-cycle-counter
)
344 (values (locally ,@body
)
345 (multiple-value-bind (,hi1
,lo1
) (%read-cycle-counter
)
346 (+ (ash (- ,hi1
,hi0
) 32)
350 (define-vop (count-me)
351 (:args
(count-vector :scs
(descriptor-reg)))
354 (inst inc
(make-ea-for-vector-data count-vector
:offset index
))))