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 (widetag-of)
17 (:translate widetag-of
)
19 (:args
(object :scs
(descriptor-reg)))
20 (:temporary
(:sc unsigned-reg
:offset eax-offset
:to
(:result
0)) eax
)
21 (:results
(result :scs
(unsigned-reg)))
22 (:result-types positive-fixnum
)
25 (inst and al-tn lowtag-mask
)
26 (inst cmp al-tn other-pointer-lowtag
)
27 (inst jmp
:e other-ptr
)
28 (inst cmp al-tn fun-pointer-lowtag
)
29 (inst jmp
:e function-ptr
)
31 ;; Pick off structures and list pointers.
36 (inst and al-tn fixnum-tag-mask
)
39 ;; must be an other immediate
44 (load-type al-tn object
(- fun-pointer-lowtag
))
48 (load-type al-tn object
(- other-pointer-lowtag
))
51 (inst movzx result al-tn
)))
53 (define-vop (%other-pointer-widetag
)
54 (:translate %other-pointer-widetag
)
56 (:args
(object :scs
(descriptor-reg)))
57 (:results
(result :scs
(unsigned-reg)))
58 (:result-types positive-fixnum
)
60 (inst movzx result
(make-ea :byte
:base object
61 :disp
(- other-pointer-lowtag
)))))
64 (define-vop (fun-subtype)
65 (:translate fun-subtype
)
67 (:args
(function :scs
(descriptor-reg)))
68 (:results
(result :scs
(unsigned-reg)))
69 (:result-types positive-fixnum
)
71 (inst movzx result
(make-ea :byte
:base function
72 :disp
(- fun-pointer-lowtag
)))))
74 (define-vop (get-header-data)
75 (:translate get-header-data
)
77 (:args
(x :scs
(descriptor-reg)))
78 (:results
(res :scs
(unsigned-reg)))
79 (:result-types positive-fixnum
)
81 (loadw res x
0 other-pointer-lowtag
)
82 (inst shr res n-widetag-bits
)))
84 (define-vop (get-closure-length)
85 (:translate get-closure-length
)
87 (:args
(x :scs
(descriptor-reg)))
88 (:results
(res :scs
(unsigned-reg)))
89 (:result-types positive-fixnum
)
91 (loadw res x
0 fun-pointer-lowtag
)
92 (inst shr res n-widetag-bits
)
93 (inst and res short-header-max-words
)))
95 (define-vop (set-header-data)
96 (:translate set-header-data
)
98 (:args
(x :scs
(descriptor-reg) :target res
:to
(:result
0))
99 (data :scs
(any-reg) :target eax
))
100 (:arg-types
* positive-fixnum
)
101 (:results
(res :scs
(descriptor-reg)))
102 (:temporary
(:sc unsigned-reg
:offset eax-offset
103 :from
(:argument
1) :to
(:result
0)) eax
)
106 (inst shl eax
(- n-widetag-bits
2))
107 (load-type al-tn x
(- other-pointer-lowtag
))
108 (storew eax x
0 other-pointer-lowtag
)
111 (define-vop (pointer-hash)
112 (:translate pointer-hash
)
113 (:args
(ptr :scs
(any-reg descriptor-reg
) :target res
))
114 (:results
(res :scs
(any-reg descriptor-reg
)))
118 ;; Mask the lowtag, and shift the whole address into a positive
120 (inst and res
(lognot lowtag-mask
))
125 (define-vop (dynamic-space-free-pointer)
126 (:results
(int :scs
(sap-reg)))
127 (:result-types system-area-pointer
)
128 (:translate dynamic-space-free-pointer
)
131 (load-symbol-value int
*allocation-pointer
*)))
133 (define-vop (binding-stack-pointer-sap)
134 (:results
(int :scs
(sap-reg)))
135 (:result-types system-area-pointer
)
136 (:translate binding-stack-pointer-sap
)
139 (load-binding-stack-pointer int
)))
141 (defknown (setf binding-stack-pointer-sap
)
142 (system-area-pointer) system-area-pointer
())
144 (define-vop (set-binding-stack-pointer-sap)
145 (:args
(new-value :scs
(sap-reg) :target int
))
146 (:arg-types system-area-pointer
)
147 (:results
(int :scs
(sap-reg)))
148 (:result-types system-area-pointer
)
149 (:translate
(setf binding-stack-pointer-sap
))
152 (store-binding-stack-pointer new-value
)
153 (move int new-value
)))
155 (define-vop (control-stack-pointer-sap)
156 (:results
(int :scs
(sap-reg)))
157 (:result-types system-area-pointer
)
158 (:translate control-stack-pointer-sap
)
163 ;;;; code object frobbing
165 (define-vop (code-instructions)
166 (:translate code-instructions
)
168 (:args
(code :scs
(descriptor-reg) :to
(:result
0)))
169 (:results
(sap :scs
(sap-reg) :from
(:argument
0)))
170 (:result-types system-area-pointer
)
172 (loadw sap code
0 other-pointer-lowtag
)
173 (inst shr sap n-widetag-bits
)
174 (inst lea sap
(make-ea :byte
:base code
:index sap
:scale
4
175 :disp
(- other-pointer-lowtag
)))))
177 (define-vop (compute-fun)
178 (:args
(code :scs
(descriptor-reg) :to
(:result
0))
179 (offset :scs
(signed-reg unsigned-reg
) :to
(:result
0)))
180 (:arg-types
* positive-fixnum
)
181 (:results
(func :scs
(descriptor-reg) :from
(:argument
0)))
183 (loadw func code
0 other-pointer-lowtag
)
184 (inst shr func n-widetag-bits
)
186 (make-ea :byte
:base offset
:index func
:scale
4
187 :disp
(- fun-pointer-lowtag other-pointer-lowtag
)))
188 (inst add func code
)))
190 ;;; This vop is quite magical - because 'closure-fun' is a raw program counter,
191 ;;; as soon as it's loaded into a register, it prevents the underlying fun from
192 ;;; being transported by GC. It's even subtler in that sense than COMPUTE-FUN,
193 ;;; which doesn't pin a *different* object produced from thin air.
194 ;;; (It's output operand is embedded in the object pointed to by its input)
195 (define-vop (%closure-fun
)
197 (:translate %closure-fun
)
198 (:args
(function :scs
(descriptor-reg)))
199 (:results
(result :scs
(descriptor-reg)))
201 (loadw result function closure-fun-slot fun-pointer-lowtag
)
203 (make-ea :byte
:base result
204 :disp
(- fun-pointer-lowtag
205 (* simple-fun-code-offset n-word-bytes
))))))
209 ;; only define if the feature is enabled to test building without it
212 (define-vop (symbol-info-vector)
214 (:translate symbol-info-vector
)
215 (:args
(x :scs
(descriptor-reg)))
216 (:results
(res :scs
(descriptor-reg)))
217 (:temporary
(:sc unsigned-reg
:offset eax-offset
) eax
)
219 (loadw res x symbol-info-slot other-pointer-lowtag
)
220 ;; If RES has list-pointer-lowtag, take its CDR. If not, use it as-is.
221 ;; This CMOV safely reads from memory when it does not move, because if
222 ;; there is an info-vector in the slot, it has at least one element.
223 ;; This would compile to almost the same code without a VOP,
224 ;; but using a jmp around a mov instead.
225 (inst lea eax
(make-ea :dword
:base res
:disp
(- list-pointer-lowtag
)))
226 (emit-optimized-test-inst eax lowtag-mask
)
228 (make-ea-for-object-slot res cons-cdr-slot list-pointer-lowtag
))))
229 (define-vop (symbol-plist)
231 (:translate symbol-plist
)
232 (:args
(x :scs
(descriptor-reg)))
233 (:results
(res :scs
(descriptor-reg)))
234 (:temporary
(:sc unsigned-reg
) temp
)
236 (loadw res x symbol-info-slot other-pointer-lowtag
)
237 ;; Instruction pun: (CAR x) is the same as (VECTOR-LENGTH x)
238 ;; so if the info slot holds a vector, this gets a fixnum- it's not a plist.
239 (loadw res res cons-car-slot list-pointer-lowtag
)
240 (inst mov temp nil-value
)
241 (emit-optimized-test-inst res fixnum-tag-mask
)
242 (inst cmov
:e res temp
))))
244 ;;;; other miscellaneous VOPs
246 (defknown sb
!unix
::receive-pending-interrupt
() (values))
247 (define-vop (sb!unix
::receive-pending-interrupt
)
249 (:translate sb
!unix
::receive-pending-interrupt
)
251 (inst break pending-interrupt-trap
)))
254 (define-vop (insert-safepoint)
256 (:translate sb
!kernel
::gc-safepoint
)
261 (defknown current-thread-offset-sap
((unsigned-byte 32))
262 system-area-pointer
(flushable))
265 (define-vop (current-thread-offset-sap)
266 (:results
(sap :scs
(sap-reg)))
267 (:result-types system-area-pointer
)
268 (:translate current-thread-offset-sap
)
269 (:args
(n :scs
(unsigned-reg)
270 #!+win32
#!+win32
:to
:save
271 #!-win32
#!-win32
:target sap
))
272 (:arg-types unsigned-num
)
277 ;; Note that SAP conflicts with N in this case, hence the reader
278 ;; conditionals above.
279 (inst mov sap
(make-ea :dword
:disp
+win32-tib-arbitrary-field-offset
+) :fs
)
280 (inst mov sap
(make-ea :dword
:base sap
:disp
0 :index n
:scale
4)))
282 (inst mov sap
(make-ea :dword
:disp
0 :index n
:scale
4) :fs
)))
286 (inst break halt-trap
)))
288 (defknown float-wait
() (values))
289 (define-vop (float-wait)
291 (:translate float-wait
)
293 (:save-p
:compute-only
)
295 (note-next-instruction vop
:internal-error
)
300 ;;; the RDTSC instruction (present on Pentium processors and
301 ;;; successors) allows you to access the time-stamp counter, a 64-bit
302 ;;; model-specific register that counts executed cycles. The
303 ;;; instruction returns the low cycle count in EAX and high cycle
306 ;;; In order to obtain more significant results on out-of-order
307 ;;; processors (such as the Pentium II and later), we issue a
308 ;;; serializing CPUID instruction before reading the cycle counter.
309 ;;; This instruction is used for its side effect of emptying the
310 ;;; processor pipeline, to ensure that the RDTSC instruction is
311 ;;; executed once all pending instructions have been completed.
312 ;;; CPUID writes to EBX and ECX in addition to EAX and EDX, so
313 ;;; they need to be added as temporaries.
315 ;;; Note that cache effects mean that the cycle count can vary for
316 ;;; different executions of the same code (it counts cycles, not
317 ;;; retired instructions). Furthermore, the results are per-processor
318 ;;; and not per-process, so are unreliable on multiprocessor machines
319 ;;; where processes can migrate between processors.
321 ;;; This method of obtaining a cycle count has the advantage of being
322 ;;; very fast (around 20 cycles), and of not requiring a system call.
323 ;;; However, you need to know your processor's clock speed to translate
324 ;;; this into real execution time.
326 ;;; FIXME: This about the WITH-CYCLE-COUNTER interface a bit, and then
327 ;;; perhaps export it from SB-SYS.
329 (defknown %read-cycle-counter
() (values (unsigned-byte 32) (unsigned-byte 32)) ())
331 (define-vop (%read-cycle-counter
)
333 (:translate %read-cycle-counter
)
334 (:temporary
(:sc unsigned-reg
:offset eax-offset
:target lo
) eax
)
335 (:temporary
(:sc unsigned-reg
:offset edx-offset
:target hi
) edx
)
336 (:temporary
(:sc unsigned-reg
:offset ebx-offset
) ebx
)
337 (:temporary
(:sc unsigned-reg
:offset ecx-offset
) ecx
)
339 (:results
(hi :scs
(unsigned-reg))
340 (lo :scs
(unsigned-reg)))
341 (:result-types unsigned-num unsigned-num
)
344 ;; Intel docs seem quite consistent on only using CPUID before RDTSC,
345 ;; not both before and after. Go figure.
351 (defmacro with-cycle-counter
(&body body
)
352 "Returns the primary value of BODY as the primary value, and the
353 number of CPU cycles elapsed as secondary value. EXPERIMENTAL."
354 (with-unique-names (hi0 hi1 lo0 lo1
)
355 `(multiple-value-bind (,hi0
,lo0
) (%read-cycle-counter
)
356 (values (locally ,@body
)
357 (multiple-value-bind (,hi1
,lo1
) (%read-cycle-counter
)
358 (+ (ash (- ,hi1
,hi0
) 32)
362 (define-vop (count-me)
363 (:args
(count-vector :scs
(descriptor-reg)))
366 (inst inc
(make-ea-for-vector-data count-vector
:offset index
))))
368 ;;;; Memory barrier support
370 #!+memory-barrier-vops
371 (define-vop (%compiler-barrier
)
373 (:translate %compiler-barrier
)
376 #!+memory-barrier-vops
377 (define-vop (%memory-barrier
)
379 (:translate %memory-barrier
)
381 (inst add
(make-ea :dword
:base esp-tn
) 0 :lock
)))
383 #!+memory-barrier-vops
384 (define-vop (%read-barrier
)
386 (:translate %read-barrier
)
389 #!+memory-barrier-vops
390 (define-vop (%write-barrier
)
392 (:translate %write-barrier
)
395 #!+memory-barrier-vops
396 (define-vop (%data-dependency-barrier
)
398 (:translate %data-dependency-barrier
)
402 (:translate spin-loop-hint
)
409 (defknown %cons-cas-pair
(cons t t t t
) (values t t
))
410 ;; These unsafely permits cmpxchg on any kind of vector, boxed or unboxed
411 ;; and the same goes for instances.
412 (defknown %vector-cas-pair
(simple-array index t t t t
) (values t t
))
413 (defknown %instance-cas-pair
(instance index t t t t
) (values t t
))
416 ((define-cmpxchg-vop (name memory-operand more-stuff
&optional index-arg
)
420 (:args
(data :scs
(descriptor-reg) :to
:eval
)
422 (expected-old-lo :scs
(descriptor-reg any-reg
) :target eax
)
423 (expected-old-hi :scs
(descriptor-reg any-reg
) :target edx
)
424 (new-lo :scs
(descriptor-reg any-reg
) :target ebx
)
425 (new-hi :scs
(descriptor-reg any-reg
) :target ecx
))
426 (:results
(result-lo :scs
(descriptor-reg any-reg
))
427 (result-hi :scs
(descriptor-reg any-reg
)))
428 (:temporary
(:sc unsigned-reg
:offset eax-offset
429 :from
(:argument
2) :to
(:result
0)) eax
)
430 (:temporary
(:sc unsigned-reg
:offset edx-offset
431 :from
(:argument
3) :to
(:result
0)) edx
)
432 (:temporary
(:sc unsigned-reg
:offset ebx-offset
433 :from
(:argument
4) :to
(:result
0)) ebx
)
434 (:temporary
(:sc unsigned-reg
:offset ecx-offset
435 :from
(:argument
5) :to
(:result
0)) ecx
)
437 (move eax expected-old-lo
)
438 (move edx expected-old-hi
)
441 (inst cmpxchg8b
,memory-operand
:lock
)
442 ;; EDX:EAX hold the actual old contents of memory.
443 ;; Manually analyze result lifetimes to avoid clobbering.
444 (cond ((and (location= result-lo edx
) (location= result-hi eax
))
445 (inst xchg eax edx
)) ; unlikely, but possible
446 ((location= result-lo edx
) ; result-hi is not eax
447 (move result-hi edx
) ; move high part first
448 (move result-lo eax
))
449 (t ; result-lo is not edx
450 (move result-lo eax
) ; move low part first
451 (move result-hi edx
)))))))
452 (define-cmpxchg-vop compare-and-exchange-pair
453 (make-ea :dword
:base data
:disp
(- list-pointer-lowtag
))
454 ((:translate %cons-cas-pair
)))
455 (define-cmpxchg-vop compare-and-exchange-pair-indexed
456 (make-ea :dword
:base data
:disp offset
:index index
457 :scale
(ash n-word-bytes
(- n-fixnum-tag-bits
)))
458 ((:variant-vars offset
))
459 ((index :scs
(descriptor-reg any-reg
) :to
:eval
))))
461 (define-vop (%vector-cas-pair compare-and-exchange-pair-indexed
)
462 (:translate %vector-cas-pair
)
463 (:variant
(- (* n-word-bytes vector-data-offset
) other-pointer-lowtag
)))
465 (define-vop (%instance-cas-pair compare-and-exchange-pair-indexed
)
466 (:translate %instance-cas-pair
)
467 (:variant
(- (* n-word-bytes instance-slots-offset
) instance-pointer-lowtag
)))
469 (defknown %cpu-identification
((unsigned-byte 32) (unsigned-byte 32))
470 (values (unsigned-byte 32) (unsigned-byte 32)
471 (unsigned-byte 32) (unsigned-byte 32)))
473 ;; The only use of CPUID heretofore was for its flushing of the I-pipeline.
474 (define-vop (%cpu-identification
)
476 (:translate %cpu-identification
)
477 (:args
(function :scs
(unsigned-reg) :target eax
)
478 (subfunction :scs
(unsigned-reg) :target ecx
))
479 (:arg-types unsigned-num unsigned-num
)
480 (:results
(a :scs
(unsigned-reg))
481 (b :scs
(unsigned-reg))
482 (c :scs
(unsigned-reg))
483 (d :scs
(unsigned-reg)))
484 (:result-types unsigned-num unsigned-num unsigned-num unsigned-num
)
485 (:temporary
(:sc unsigned-reg
:from
(:argument
0) :to
(:result
0)
486 :offset eax-offset
) eax
)
487 (:temporary
(:sc unsigned-reg
:from
(:argument
1) :to
(:result
2)
488 :offset ecx-offset
) ecx
)
489 (:temporary
(:sc unsigned-reg
:from
:eval
:to
(:result
3)
490 :offset edx-offset
) edx
)
491 (:temporary
(:sc unsigned-reg
:from
:eval
:to
(:result
1)
492 :offset ebx-offset
) ebx
)
495 (move ecx subfunction
)