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)) rax
)
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.
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 rax-offset
:from
(:argument
0)
82 :to
(:result
0) :target result
)
84 (:results
(result :scs
(unsigned-reg)))
85 (:result-types positive-fixnum
)
89 (make-ea :byte
:base function
:disp
(- fun-pointer-lowtag
))
93 (define-vop (get-header-data)
94 (:translate get-header-data
)
96 (:args
(x :scs
(descriptor-reg)))
97 (:results
(res :scs
(unsigned-reg)))
98 (:result-types positive-fixnum
)
100 (loadw res x
0 other-pointer-lowtag
)
101 (inst shr res n-widetag-bits
)))
103 (define-vop (get-closure-length)
104 (:translate get-closure-length
)
106 (:args
(x :scs
(descriptor-reg)))
107 (:results
(res :scs
(unsigned-reg)))
108 (:result-types positive-fixnum
)
110 (loadw res x
0 fun-pointer-lowtag
)
111 (inst shr res n-widetag-bits
)))
113 (define-vop (set-header-data)
114 (:translate set-header-data
)
116 (:args
(x :scs
(descriptor-reg) :target res
:to
(:result
0))
117 (data :scs
(any-reg) :target eax
))
118 (:arg-types
* positive-fixnum
)
119 (:results
(res :scs
(descriptor-reg)))
120 (:temporary
(:sc unsigned-reg
:offset eax-offset
121 :from
(:argument
1) :to
(:result
0)) eax
)
124 (inst shl eax
(- n-widetag-bits n-fixnum-tag-bits
))
125 (inst mov al-tn
(make-ea :byte
:base x
:disp
(- other-pointer-lowtag
)))
126 (storew eax x
0 other-pointer-lowtag
)
129 (define-vop (pointer-hash)
130 (:translate pointer-hash
)
131 (:args
(ptr :scs
(any-reg descriptor-reg
) :target res
))
132 (:results
(res :scs
(any-reg descriptor-reg
)))
136 ;; Mask the lowtag, and shift the whole address into a positive
138 (inst and res
(lognot lowtag-mask
))
141 (define-vop (make-other-immediate-type)
142 (:args
(val :scs
(any-reg descriptor-reg
) :target res
)
143 (type :scs
(unsigned-reg immediate
)))
144 (:results
(res :scs
(any-reg descriptor-reg
) :from
(:argument
0)))
147 (inst shl res
(- n-widetag-bits n-fixnum-tag-bits
))
148 (inst or res
(sc-case type
150 (immediate (tn-value type
))))))
154 (define-vop (dynamic-space-free-pointer)
155 (:results
(int :scs
(sap-reg)))
156 (:result-types system-area-pointer
)
157 (:translate dynamic-space-free-pointer
)
160 (load-symbol-value int
*allocation-pointer
*)))
162 (define-vop (binding-stack-pointer-sap)
163 (:results
(int :scs
(sap-reg)))
164 (:result-types system-area-pointer
)
165 (:translate binding-stack-pointer-sap
)
168 (load-binding-stack-pointer int
)))
170 (defknown (setf binding-stack-pointer-sap
)
171 (system-area-pointer) system-area-pointer
())
173 (define-vop (set-binding-stack-pointer-sap)
174 (:args
(new-value :scs
(sap-reg) :target int
))
175 (:arg-types system-area-pointer
)
176 (:results
(int :scs
(sap-reg)))
177 (:result-types system-area-pointer
)
178 (:translate
(setf binding-stack-pointer-sap
))
181 (store-binding-stack-pointer new-value
)
182 (move int new-value
)))
184 (define-vop (control-stack-pointer-sap)
185 (:results
(int :scs
(sap-reg)))
186 (:result-types system-area-pointer
)
187 (:translate control-stack-pointer-sap
)
192 ;;;; code object frobbing
194 (define-vop (code-instructions)
195 (:translate code-instructions
)
197 (:args
(code :scs
(descriptor-reg) :to
(:result
0)))
198 (:results
(sap :scs
(sap-reg) :from
(:argument
0)))
199 (:result-types system-area-pointer
)
201 (loadw sap code
0 other-pointer-lowtag
)
202 (inst shr sap n-widetag-bits
)
203 (inst lea sap
(make-ea :byte
:base code
:index sap
205 :disp
(- other-pointer-lowtag
)))))
207 (define-vop (compute-fun)
208 (:args
(code :scs
(descriptor-reg) :to
(:result
0))
209 (offset :scs
(signed-reg unsigned-reg
) :to
(:result
0)))
210 (:arg-types
* positive-fixnum
)
211 (:results
(func :scs
(descriptor-reg) :from
(:argument
0)))
213 (loadw func code
0 other-pointer-lowtag
)
214 (inst shr func n-widetag-bits
)
216 (make-ea :byte
:base offset
:index func
218 :disp
(- fun-pointer-lowtag other-pointer-lowtag
)))
219 (inst add func code
)))
221 (define-vop (%simple-fun-self
)
223 (:translate %simple-fun-self
)
224 (:args
(function :scs
(descriptor-reg)))
225 (:results
(result :scs
(descriptor-reg)))
227 (loadw result function simple-fun-self-slot fun-pointer-lowtag
)
229 (make-ea :byte
:base result
230 :disp
(- fun-pointer-lowtag
231 (* simple-fun-code-offset n-word-bytes
))))))
233 ;;; The closure function slot is a pointer to raw code on X86 instead
234 ;;; of a pointer to the code function object itself. This VOP is used
235 ;;; to reference the function object given the closure object.
236 (define-source-transform %closure-fun
(closure)
237 `(%simple-fun-self
,closure
))
239 (define-vop (%set-fun-self
)
241 (:translate
(setf %simple-fun-self
))
242 (:args
(new-self :scs
(descriptor-reg) :target result
:to
:result
)
243 (function :scs
(descriptor-reg) :to
:result
))
244 (:temporary
(:sc any-reg
:from
(:argument
0) :to
:result
) temp
)
245 (:results
(result :scs
(descriptor-reg)))
248 (make-ea :byte
:base new-self
249 :disp
(- (ash simple-fun-code-offset word-shift
)
250 fun-pointer-lowtag
)))
251 (storew temp function simple-fun-self-slot fun-pointer-lowtag
)
252 (move result new-self
)))
254 ;;;; other miscellaneous VOPs
256 (defknown sb
!unix
::receive-pending-interrupt
() (values))
257 (define-vop (sb!unix
::receive-pending-interrupt
)
259 (:translate sb
!unix
::receive-pending-interrupt
)
261 (inst break pending-interrupt-trap
)))
264 (defknown current-thread-offset-sap
((unsigned-byte 64))
265 system-area-pointer
(flushable))
268 (define-vop (current-thread-offset-sap)
269 (:results
(sap :scs
(sap-reg)))
270 (:result-types system-area-pointer
)
271 (:translate current-thread-offset-sap
)
272 (:args
(n :scs
(unsigned-reg) :target sap
))
273 (:arg-types unsigned-num
)
277 (make-ea :qword
:base thread-base-tn
:disp
0 :index n
:scale
8))))
281 (inst break halt-trap
)))
283 (defknown float-wait
() (values))
284 (define-vop (float-wait)
286 (:translate float-wait
)
288 (:save-p
:compute-only
)
290 (note-next-instruction vop
:internal-error
)
295 ;;; the RDTSC instruction (present on Pentium processors and
296 ;;; successors) allows you to access the time-stamp counter, a 64-bit
297 ;;; model-specific register that counts executed cycles. The
298 ;;; instruction returns the low cycle count in EAX and high cycle
301 ;;; In order to obtain more significant results on out-of-order
302 ;;; processors (such as the Pentium II and later), we issue a
303 ;;; serializing CPUID instruction before and after reading the cycle
304 ;;; counter. This instruction is used for its side effect of emptying
305 ;;; the processor pipeline, to ensure that the RDTSC instruction is
306 ;;; executed once all pending instructions have been completed and
307 ;;; before any others. CPUID writes to EBX and ECX in addition to EAX
308 ;;; and EDX, so they need to be added as temporaries.
310 ;;; Note that cache effects mean that the cycle count can vary for
311 ;;; different executions of the same code (it counts cycles, not
312 ;;; retired instructions). Furthermore, the results are per-processor
313 ;;; and not per-process, so are unreliable on multiprocessor machines
314 ;;; where processes can migrate between processors.
316 ;;; This method of obtaining a cycle count has the advantage of being
317 ;;; very fast (around 20 cycles), and of not requiring a system call.
318 ;;; However, you need to know your processor's clock speed to translate
319 ;;; this into real execution time.
321 ;;; FIXME: This about the WITH-CYCLE-COUNTER interface a bit, and then
322 ;;; perhaps export it from SB-SYS.
324 (defknown %read-cycle-counter
() (values (unsigned-byte 32) (unsigned-byte 32)) ())
326 (define-vop (%read-cycle-counter
)
328 (:translate %read-cycle-counter
)
329 (:temporary
(:sc unsigned-reg
:offset eax-offset
:target lo
) eax
)
330 (:temporary
(:sc unsigned-reg
:offset edx-offset
:target hi
) edx
)
331 (:temporary
(:sc unsigned-reg
:offset ebx-offset
) ebx
)
332 (:temporary
(:sc unsigned-reg
:offset ecx-offset
) ecx
)
334 (:results
(hi :scs
(unsigned-reg))
335 (lo :scs
(unsigned-reg)))
336 (:result-types unsigned-num unsigned-num
)
339 ;; Intel docs seem quite consistent on only using CPUID before RDTSC,
340 ;; not both before and after. Go figure.
346 (defmacro with-cycle-counter
(&body body
)
347 "Returns the primary value of BODY as the primary value, and the
348 number of CPU cycles elapsed as secondary value. EXPERIMENTAL."
349 (with-unique-names (hi0 hi1 lo0 lo1
)
350 `(multiple-value-bind (,hi0
,lo0
) (%read-cycle-counter
)
351 (values (locally ,@body
)
352 (multiple-value-bind (,hi1
,lo1
) (%read-cycle-counter
)
353 (+ (ash (- ,hi1
,hi0
) 32)
357 (define-vop (count-me)
358 (:args
(count-vector :scs
(descriptor-reg)))
361 (inst inc
(make-ea :qword
:base count-vector
362 :disp
(- (* (+ vector-data-offset index
) n-word-bytes
)
363 other-pointer-lowtag
)))))