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 (%other-pointer-widetag
)
65 (:translate %other-pointer-widetag
)
67 (:args
(object :scs
(descriptor-reg)))
68 (:results
(result :scs
(unsigned-reg)))
69 (:result-types positive-fixnum
)
71 (inst movzx result
(make-ea :byte
:base object
72 :disp
(- other-pointer-lowtag
)))))
75 (define-vop (fun-subtype)
76 (:translate fun-subtype
)
78 (:args
(function :scs
(descriptor-reg)))
79 (:results
(result :scs
(unsigned-reg)))
80 (:result-types positive-fixnum
)
82 (inst movzx result
(make-ea :byte
:base function
83 :disp
(- fun-pointer-lowtag
)))))
85 (define-vop (set-fun-subtype)
86 (:translate
(setf fun-subtype
))
88 (:args
(type :scs
(unsigned-reg) :target eax
)
89 (function :scs
(descriptor-reg)))
90 (:arg-types positive-fixnum
*)
91 (:temporary
(:sc unsigned-reg
:offset eax-offset
:from
(:argument
0)
92 :to
(:result
0) :target result
)
94 (:results
(result :scs
(unsigned-reg)))
95 (:result-types positive-fixnum
)
98 (storeb al-tn function
0 fun-pointer-lowtag
)
101 (define-vop (get-header-data)
102 (:translate get-header-data
)
104 (:args
(x :scs
(descriptor-reg)))
105 (:results
(res :scs
(unsigned-reg)))
106 (:result-types positive-fixnum
)
108 (loadw res x
0 other-pointer-lowtag
)
109 (inst shr res n-widetag-bits
)))
111 (define-vop (get-closure-length)
112 (:translate get-closure-length
)
114 (:args
(x :scs
(descriptor-reg)))
115 (:results
(res :scs
(unsigned-reg)))
116 (:result-types positive-fixnum
)
118 (loadw res x
0 fun-pointer-lowtag
)
119 (inst shr res n-widetag-bits
)))
121 (define-vop (set-header-data)
122 (:translate set-header-data
)
124 (:args
(x :scs
(descriptor-reg) :target res
:to
(:result
0))
125 (data :scs
(any-reg) :target eax
))
126 (:arg-types
* positive-fixnum
)
127 (:results
(res :scs
(descriptor-reg)))
128 (:temporary
(:sc unsigned-reg
:offset eax-offset
129 :from
(:argument
1) :to
(:result
0)) eax
)
132 (inst shl eax
(- n-widetag-bits
2))
133 (load-type al-tn x
(- other-pointer-lowtag
))
134 (storew eax x
0 other-pointer-lowtag
)
137 (define-vop (pointer-hash)
138 (:translate pointer-hash
)
139 (:args
(ptr :scs
(any-reg descriptor-reg
) :target res
))
140 (:results
(res :scs
(any-reg descriptor-reg
)))
144 ;; Mask the lowtag, and shift the whole address into a positive
146 (inst and res
(lognot lowtag-mask
))
151 (define-vop (dynamic-space-free-pointer)
152 (:results
(int :scs
(sap-reg)))
153 (:result-types system-area-pointer
)
154 (:translate dynamic-space-free-pointer
)
157 (load-symbol-value int
*allocation-pointer
*)))
159 (define-vop (binding-stack-pointer-sap)
160 (:results
(int :scs
(sap-reg)))
161 (:result-types system-area-pointer
)
162 (:translate binding-stack-pointer-sap
)
165 (load-binding-stack-pointer int
)))
167 (defknown (setf binding-stack-pointer-sap
)
168 (system-area-pointer) system-area-pointer
())
170 (define-vop (set-binding-stack-pointer-sap)
171 (:args
(new-value :scs
(sap-reg) :target int
))
172 (:arg-types system-area-pointer
)
173 (:results
(int :scs
(sap-reg)))
174 (:result-types system-area-pointer
)
175 (:translate
(setf binding-stack-pointer-sap
))
178 (store-binding-stack-pointer new-value
)
179 (move int new-value
)))
181 (define-vop (control-stack-pointer-sap)
182 (:results
(int :scs
(sap-reg)))
183 (:result-types system-area-pointer
)
184 (:translate control-stack-pointer-sap
)
189 ;;;; code object frobbing
191 (define-vop (code-instructions)
192 (:translate code-instructions
)
194 (:args
(code :scs
(descriptor-reg) :to
(:result
0)))
195 (:results
(sap :scs
(sap-reg) :from
(:argument
0)))
196 (:result-types system-area-pointer
)
198 (loadw sap code
0 other-pointer-lowtag
)
199 (inst shr sap n-widetag-bits
)
200 (inst lea sap
(make-ea :byte
:base code
:index sap
:scale
4
201 :disp
(- other-pointer-lowtag
)))))
203 (define-vop (compute-fun)
204 (:args
(code :scs
(descriptor-reg) :to
(:result
0))
205 (offset :scs
(signed-reg unsigned-reg
) :to
(:result
0)))
206 (:arg-types
* positive-fixnum
)
207 (:results
(func :scs
(descriptor-reg) :from
(:argument
0)))
209 (loadw func code
0 other-pointer-lowtag
)
210 (inst shr func n-widetag-bits
)
212 (make-ea :byte
:base offset
:index func
:scale
4
213 :disp
(- fun-pointer-lowtag other-pointer-lowtag
)))
214 (inst add func code
)))
216 (define-vop (%simple-fun-self
)
218 (:translate %simple-fun-self
)
219 (:args
(function :scs
(descriptor-reg)))
220 (:results
(result :scs
(descriptor-reg)))
222 (loadw result function simple-fun-self-slot fun-pointer-lowtag
)
224 (make-ea :byte
:base result
225 :disp
(- fun-pointer-lowtag
226 (* simple-fun-code-offset n-word-bytes
))))))
228 ;;; The closure function slot is a pointer to raw code on X86 instead
229 ;;; of a pointer to the code function object itself. This VOP is used
230 ;;; to reference the function object given the closure object.
231 (define-source-transform %closure-fun
(closure)
232 `(%simple-fun-self
,closure
))
234 (define-vop (%set-fun-self
)
236 (:translate
(setf %simple-fun-self
))
237 (:args
(new-self :scs
(descriptor-reg) :target result
:to
:result
)
238 (function :scs
(descriptor-reg) :to
:result
))
239 (:temporary
(:sc any-reg
:from
(:argument
0) :to
:result
) temp
)
240 (:results
(result :scs
(descriptor-reg)))
242 (inst lea temp
(make-ea-for-object-slot new-self simple-fun-code-offset
244 (storew temp function simple-fun-self-slot fun-pointer-lowtag
)
245 (move result new-self
)))
249 ;; only define if the feature is enabled to test building without it
252 (define-vop (symbol-info-vector)
254 (:translate symbol-info-vector
)
255 (:args
(x :scs
(descriptor-reg)))
256 (:results
(res :scs
(descriptor-reg)))
257 (:temporary
(:sc unsigned-reg
:offset eax-offset
) eax
)
259 (loadw res x symbol-info-slot other-pointer-lowtag
)
260 ;; If RES has list-pointer-lowtag, take its CDR. If not, use it as-is.
261 ;; This CMOV safely reads from memory when it does not move, because if
262 ;; there is an info-vector in the slot, it has at least one element.
263 ;; This would compile to almost the same code without a VOP,
264 ;; but using a jmp around a mov instead.
265 (inst lea eax
(make-ea :dword
:base res
:disp
(- list-pointer-lowtag
)))
266 (emit-optimized-test-inst eax lowtag-mask
)
268 (make-ea-for-object-slot res cons-cdr-slot list-pointer-lowtag
))))
269 (define-vop (symbol-plist)
271 (:translate symbol-plist
)
272 (:args
(x :scs
(descriptor-reg)))
273 (:results
(res :scs
(descriptor-reg)))
274 (:temporary
(:sc unsigned-reg
) temp
)
276 (loadw res x symbol-info-slot other-pointer-lowtag
)
277 ;; Instruction pun: (CAR x) is the same as (VECTOR-LENGTH x)
278 ;; so if the info slot holds a vector, this gets a fixnum- it's not a plist.
279 (loadw res res cons-car-slot list-pointer-lowtag
)
280 (inst mov temp nil-value
)
281 (emit-optimized-test-inst res fixnum-tag-mask
)
282 (inst cmov
:e res temp
))))
284 ;;;; other miscellaneous VOPs
286 (defknown sb
!unix
::receive-pending-interrupt
() (values))
287 (define-vop (sb!unix
::receive-pending-interrupt
)
289 (:translate sb
!unix
::receive-pending-interrupt
)
291 (inst break pending-interrupt-trap
)))
294 (define-vop (insert-safepoint)
296 (:translate sb
!kernel
::gc-safepoint
)
301 (defknown current-thread-offset-sap
((unsigned-byte 32))
302 system-area-pointer
(flushable))
305 (define-vop (current-thread-offset-sap)
306 (:results
(sap :scs
(sap-reg)))
307 (:result-types system-area-pointer
)
308 (:translate current-thread-offset-sap
)
309 (:args
(n :scs
(unsigned-reg)
310 #!+win32
#!+win32
:to
:save
311 #!-win32
#!-win32
:target sap
))
312 (:arg-types unsigned-num
)
317 ;; Note that SAP conflicts with N in this case, hence the reader
318 ;; conditionals above.
319 (inst mov sap
(make-ea :dword
:disp
+win32-tib-arbitrary-field-offset
+) :fs
)
320 (inst mov sap
(make-ea :dword
:base sap
:disp
0 :index n
:scale
4)))
322 (inst mov sap
(make-ea :dword
:disp
0 :index n
:scale
4) :fs
)))
326 (inst break halt-trap
)))
328 (defknown float-wait
() (values))
329 (define-vop (float-wait)
331 (:translate float-wait
)
333 (:save-p
:compute-only
)
335 (note-next-instruction vop
:internal-error
)
340 ;;; the RDTSC instruction (present on Pentium processors and
341 ;;; successors) allows you to access the time-stamp counter, a 64-bit
342 ;;; model-specific register that counts executed cycles. The
343 ;;; instruction returns the low cycle count in EAX and high cycle
346 ;;; In order to obtain more significant results on out-of-order
347 ;;; processors (such as the Pentium II and later), we issue a
348 ;;; serializing CPUID instruction before reading the cycle counter.
349 ;;; This instruction is used for its side effect of emptying the
350 ;;; processor pipeline, to ensure that the RDTSC instruction is
351 ;;; executed once all pending instructions have been completed.
352 ;;; CPUID writes to EBX and ECX in addition to EAX and EDX, so
353 ;;; they need to be added as temporaries.
355 ;;; Note that cache effects mean that the cycle count can vary for
356 ;;; different executions of the same code (it counts cycles, not
357 ;;; retired instructions). Furthermore, the results are per-processor
358 ;;; and not per-process, so are unreliable on multiprocessor machines
359 ;;; where processes can migrate between processors.
361 ;;; This method of obtaining a cycle count has the advantage of being
362 ;;; very fast (around 20 cycles), and of not requiring a system call.
363 ;;; However, you need to know your processor's clock speed to translate
364 ;;; this into real execution time.
366 ;;; FIXME: This about the WITH-CYCLE-COUNTER interface a bit, and then
367 ;;; perhaps export it from SB-SYS.
369 (defknown %read-cycle-counter
() (values (unsigned-byte 32) (unsigned-byte 32)) ())
371 (define-vop (%read-cycle-counter
)
373 (:translate %read-cycle-counter
)
374 (:temporary
(:sc unsigned-reg
:offset eax-offset
:target lo
) eax
)
375 (:temporary
(:sc unsigned-reg
:offset edx-offset
:target hi
) edx
)
376 (:temporary
(:sc unsigned-reg
:offset ebx-offset
) ebx
)
377 (:temporary
(:sc unsigned-reg
:offset ecx-offset
) ecx
)
379 (:results
(hi :scs
(unsigned-reg))
380 (lo :scs
(unsigned-reg)))
381 (:result-types unsigned-num unsigned-num
)
384 ;; Intel docs seem quite consistent on only using CPUID before RDTSC,
385 ;; not both before and after. Go figure.
391 (defmacro with-cycle-counter
(&body body
)
392 "Returns the primary value of BODY as the primary value, and the
393 number of CPU cycles elapsed as secondary value. EXPERIMENTAL."
394 (with-unique-names (hi0 hi1 lo0 lo1
)
395 `(multiple-value-bind (,hi0
,lo0
) (%read-cycle-counter
)
396 (values (locally ,@body
)
397 (multiple-value-bind (,hi1
,lo1
) (%read-cycle-counter
)
398 (+ (ash (- ,hi1
,hi0
) 32)
402 (define-vop (count-me)
403 (:args
(count-vector :scs
(descriptor-reg)))
406 (inst inc
(make-ea-for-vector-data count-vector
:offset index
))))
408 ;;;; Memory barrier support
410 #!+memory-barrier-vops
411 (define-vop (%compiler-barrier
)
413 (:translate %compiler-barrier
)
416 #!+memory-barrier-vops
417 (define-vop (%memory-barrier
)
419 (:translate %memory-barrier
)
421 (inst add
(make-ea :dword
:base esp-tn
) 0 :lock
)))
423 #!+memory-barrier-vops
424 (define-vop (%read-barrier
)
426 (:translate %read-barrier
)
429 #!+memory-barrier-vops
430 (define-vop (%write-barrier
)
432 (:translate %write-barrier
)
435 #!+memory-barrier-vops
436 (define-vop (%data-dependency-barrier
)
438 (:translate %data-dependency-barrier
)
442 (:translate spin-loop-hint
)
449 (defknown %cons-cas-pair
(cons t t t t
) (values t t
))
450 ;; These unsafely permits cmpxchg on any kind of vector, boxed or unboxed
451 ;; and the same goes for instances.
452 (defknown %vector-cas-pair
(simple-array index t t t t
) (values t t
))
453 (defknown %instance-cas-pair
(instance index t t t t
) (values t t
))
456 ((define-cmpxchg-vop (name memory-operand more-stuff
&optional index-arg
)
460 (:args
(data :scs
(descriptor-reg) :to
:eval
)
462 (expected-old-lo :scs
(descriptor-reg any-reg
) :target eax
)
463 (expected-old-hi :scs
(descriptor-reg any-reg
) :target edx
)
464 (new-lo :scs
(descriptor-reg any-reg
) :target ebx
)
465 (new-hi :scs
(descriptor-reg any-reg
) :target ecx
))
466 (:results
(result-lo :scs
(descriptor-reg any-reg
))
467 (result-hi :scs
(descriptor-reg any-reg
)))
468 (:temporary
(:sc unsigned-reg
:offset eax-offset
469 :from
(:argument
2) :to
(:result
0)) eax
)
470 (:temporary
(:sc unsigned-reg
:offset edx-offset
471 :from
(:argument
3) :to
(:result
0)) edx
)
472 (:temporary
(:sc unsigned-reg
:offset ebx-offset
473 :from
(:argument
4) :to
(:result
0)) ebx
)
474 (:temporary
(:sc unsigned-reg
:offset ecx-offset
475 :from
(:argument
5) :to
(:result
0)) ecx
)
477 (move eax expected-old-lo
)
478 (move edx expected-old-hi
)
481 (inst cmpxchg8b
,memory-operand
:lock
)
482 ;; EDX:EAX hold the actual old contents of memory.
483 ;; Manually analyze result lifetimes to avoid clobbering.
484 (cond ((and (location= result-lo edx
) (location= result-hi eax
))
485 (inst xchg eax edx
)) ; unlikely, but possible
486 ((location= result-lo edx
) ; result-hi is not eax
487 (move result-hi edx
) ; move high part first
488 (move result-lo eax
))
489 (t ; result-lo is not edx
490 (move result-lo eax
) ; move low part first
491 (move result-hi edx
)))))))
492 (define-cmpxchg-vop compare-and-exchange-pair
493 (make-ea :dword
:base data
:disp
(- list-pointer-lowtag
))
494 ((:translate %cons-cas-pair
)))
495 (define-cmpxchg-vop compare-and-exchange-pair-indexed
496 (make-ea :dword
:base data
:disp offset
:index index
497 :scale
(ash n-word-bytes
(- n-fixnum-tag-bits
)))
498 ((:variant-vars offset
))
499 ((index :scs
(descriptor-reg any-reg
) :to
:eval
))))
501 (define-vop (%vector-cas-pair compare-and-exchange-pair-indexed
)
502 (:translate %vector-cas-pair
)
503 (:variant
(- (* n-word-bytes vector-data-offset
) other-pointer-lowtag
)))
505 (define-vop (%instance-cas-pair compare-and-exchange-pair-indexed
)
506 (:translate %instance-cas-pair
)
507 (:variant
(- (* n-word-bytes instance-slots-offset
) instance-pointer-lowtag
)))
509 (defknown %cpu-identification
((unsigned-byte 32) (unsigned-byte 32))
510 (values (unsigned-byte 32) (unsigned-byte 32)
511 (unsigned-byte 32) (unsigned-byte 32)))
513 ;; The only use of CPUID heretofore was for its flushing of the I-pipeline.
514 (define-vop (%cpu-identification
)
516 (:translate %cpu-identification
)
517 (:args
(function :scs
(unsigned-reg) :target eax
)
518 (subfunction :scs
(unsigned-reg) :target ecx
))
519 (:arg-types unsigned-num unsigned-num
)
520 (:results
(a :scs
(unsigned-reg))
521 (b :scs
(unsigned-reg))
522 (c :scs
(unsigned-reg))
523 (d :scs
(unsigned-reg)))
524 (:result-types unsigned-num unsigned-num unsigned-num unsigned-num
)
525 (:temporary
(:sc unsigned-reg
:from
(:argument
0) :to
(:result
0)
526 :offset eax-offset
) eax
)
527 (:temporary
(:sc unsigned-reg
:from
(:argument
1) :to
(:result
2)
528 :offset ecx-offset
) ecx
)
529 (:temporary
(:sc unsigned-reg
:from
:eval
:to
(:result
3)
530 :offset edx-offset
) edx
)
531 (:temporary
(:sc unsigned-reg
:from
:eval
:to
(:result
1)
532 :offset ebx-offset
) ebx
)
535 (move ecx subfunction
)