9207b5b020178656060095ad6d6317d436faf2ce
[projects/cmucl/cmucl.git] / src / compiler / x86 / system.lisp
1 4;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;; If you want to use this code or any part of CMU Common Lisp, please contact
7 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
8 ;;;
9 (ext:file-comment
10  "$Header: src/compiler/x86/system.lisp $")
11 ;;;
12 ;;; **********************************************************************
13 ;;;
14 ;;; x86 VM definitions of various system hacking operations.
15 ;;;
16 ;;; Written by William Lott.
17 ;;;
18 ;;; Debugged by Paul F. Werkowski Spring/Summer 1995.
19 ;;; Enhancements/debugging by Douglas T. Crosher 1996,1997,1998,1999.
20 ;;;
21
22 (in-package :x86)
23 (intl:textdomain "cmucl-x86-vm")
24
25 \f
26 ;;;; Type frobbing VOPs
27
28 (define-vop (get-lowtag)
29   (:translate get-lowtag)
30   (:policy :fast-safe)
31   (:args (object :scs (any-reg descriptor-reg control-stack)
32                  :target result))
33   (:results (result :scs (unsigned-reg)))
34   (:result-types positive-fixnum)
35   (:generator 1
36     (move result object)
37     (inst and result lowtag-mask)))
38
39 (define-vop (get-type)
40   (:translate get-type)
41   (:policy :fast-safe)
42   (:args (object :scs (descriptor-reg)))
43   (:temporary (:sc unsigned-reg :offset eax-offset :to (:result 0)) eax)
44   (:results (result :scs (unsigned-reg)))
45   (:result-types positive-fixnum)
46   (:generator 6
47     (inst mov eax object)
48     (inst and al-tn lowtag-mask)
49     (inst cmp al-tn other-pointer-type)
50     (inst jmp :e other-ptr)
51     (inst cmp al-tn function-pointer-type)
52     (inst jmp :e function-ptr)
53
54     ;; pick off structures and list pointers
55     (inst test al-tn 1)
56     (inst jmp :ne done)
57
58     ;; pick off fixnums
59     (inst and al-tn 3)
60     (inst jmp :e done)
61
62     ;; must be an other immediate
63     (inst mov eax object)
64     (inst jmp done)
65     
66     FUNCTION-PTR
67     (load-type al-tn object (- vm:function-pointer-type))
68     (inst jmp done)
69     
70     OTHER-PTR
71     (load-type al-tn object (- vm:other-pointer-type))
72     
73     DONE
74     (inst movzx result al-tn)))
75 \f
76 (define-vop (function-subtype)
77   (:translate function-subtype)
78   (:policy :fast-safe)
79   (:args (function :scs (descriptor-reg)))
80   (:temporary (:sc byte-reg :from (:eval 0) :to (:eval 1)) temp)
81   (:results (result :scs (unsigned-reg)))
82   (:result-types positive-fixnum)
83   (:generator 6
84     (load-type temp function (- vm:function-pointer-type))
85     (inst movzx result temp)))
86
87 (define-vop (set-function-subtype)
88   (:translate (setf function-subtype))
89   (:policy :fast-safe)
90   (:args (type :scs (unsigned-reg) :target eax)
91          (function :scs (descriptor-reg)))
92   (:arg-types positive-fixnum *)
93   (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
94                    :to (:result 0) :target result)
95               eax)
96   (:results (result :scs (unsigned-reg)))
97   (:result-types positive-fixnum)
98   (:generator 6
99     (move eax type)
100     (inst mov
101           (make-ea :byte :base function :disp (- function-pointer-type))
102           al-tn)
103     (move result eax)))
104
105 (define-vop (get-header-data)
106   (:translate get-header-data)
107   (:policy :fast-safe)
108   (:args (x :scs (descriptor-reg)))
109   (:results (res :scs (unsigned-reg)))
110   (:result-types positive-fixnum)
111   (:generator 6
112     (loadw res x 0 other-pointer-type)
113     (inst shr res type-bits)))
114
115 (define-vop (get-closure-length)
116   (:translate get-closure-length)
117   (:policy :fast-safe)
118   (:args (x :scs (descriptor-reg)))
119   (:results (res :scs (unsigned-reg)))
120   (:result-types positive-fixnum)
121   (:generator 6
122     (loadw res x 0 function-pointer-type)
123     (inst shr res type-bits)))
124
125 (define-vop (set-header-data)
126   (:translate set-header-data)
127   (:policy :fast-safe)
128   (:args (x :scs (descriptor-reg) :target res :to (:result 0))
129          (data :scs (any-reg) :target eax))
130   (:arg-types * positive-fixnum)
131   (:results (res :scs (descriptor-reg)))
132   (:temporary (:sc unsigned-reg :offset eax-offset
133                    :from (:argument 1) :to (:result 0)) eax)
134   (:generator 6
135     (move eax data)
136     (inst shl eax (- type-bits 2))
137     (inst mov al-tn (make-ea :byte :base x :disp (- other-pointer-type)))
138     (storew eax x 0 other-pointer-type)
139     (move res x)))
140 \f
141 (define-vop (make-fixnum)
142   (:args (ptr :scs (any-reg descriptor-reg) :target res))
143   (:results (res :scs (any-reg descriptor-reg)))
144   (:generator 1
145     ;;
146     ;; Some code (the hash table code) depends on this returning a
147     ;; positive number so make sure it does.
148     (move res ptr)
149     (inst shl res 3)
150     (inst shr res 1)))
151
152 (define-vop (make-other-immediate-type)
153   (:args (val :scs (any-reg descriptor-reg) :target res)
154          (type :scs (unsigned-reg immediate)))
155   (:results (res :scs (any-reg descriptor-reg) :from (:argument 0)))
156   (:generator 2
157     (move res val)
158     (inst shl res (- type-bits 2))
159     (inst or res (sc-case type
160                    (unsigned-reg type)
161                    (immediate (tn-value type))))))
162
163 \f
164 ;;;; Allocation
165
166 (define-vop (dynamic-space-free-pointer)
167   (:results (int :scs (sap-reg)))
168   (:result-types system-area-pointer)
169   (:translate dynamic-space-free-pointer)
170   (:policy :fast-safe)
171   (:generator 1
172     (load-symbol-value int *allocation-pointer*)))
173
174 (define-vop (binding-stack-pointer-sap)
175   (:results (int :scs (sap-reg)))
176   (:result-types system-area-pointer)
177   (:translate binding-stack-pointer-sap)
178   (:policy :fast-safe)
179   (:generator 1
180     (load-symbol-value int *binding-stack-pointer*)))
181
182 (defknown (setf binding-stack-pointer-sap)
183     (system-area-pointer) system-area-pointer ())
184
185 (define-vop (set-binding-stack-pointer-sap)
186   (:args (new-value :scs (sap-reg) :target int))
187   (:arg-types system-area-pointer)
188   (:results (int :scs (sap-reg)))
189   (:result-types system-area-pointer)
190   (:translate (setf binding-stack-pointer-sap))
191   (:policy :fast-safe)
192   (:generator 1
193     (store-symbol-value new-value *binding-stack-pointer*)
194     (move int new-value)))
195
196 (define-vop (control-stack-pointer-sap)
197   (:results (int :scs (sap-reg)))
198   (:result-types system-area-pointer)
199   (:translate control-stack-pointer-sap)
200   (:policy :fast-safe)
201   (:generator 1
202     (move int esp-tn)))
203
204 \f
205 ;;;; Code object frobbing.
206
207 (define-vop (code-instructions)
208   (:translate code-instructions)
209   (:policy :fast-safe)
210   (:args (code :scs (descriptor-reg) :to (:result 0)))
211   (:results (sap :scs (sap-reg) :from (:argument 0)))
212   (:result-types system-area-pointer)
213   (:generator 10
214     (loadw sap code 0 other-pointer-type)
215     (inst shr sap type-bits)
216     (inst lea sap (make-ea :byte :base code :index sap :scale 4
217                            :disp (- other-pointer-type)))))
218
219 (define-vop (compute-function)
220   (:args (code :scs (descriptor-reg) :to (:result 0))
221          (offset :scs (signed-reg unsigned-reg) :to (:result 0)))
222   (:arg-types * positive-fixnum)
223   (:results (func :scs (descriptor-reg) :from (:argument 0)))
224   (:generator 10
225     (loadw func code 0 other-pointer-type)
226     (inst shr func type-bits)
227     (inst lea func
228           (make-ea :byte :base offset :index func :scale 4
229                    :disp (- function-pointer-type other-pointer-type)))
230     (inst add func code)))
231
232 (defknown %function-self (function) function (flushable))
233
234 (define-vop (%function-self)
235   (:policy :fast-safe)
236   (:translate %function-self)
237   (:args (function :scs (descriptor-reg)))
238   (:results (result :scs (descriptor-reg)))
239   (:generator 3
240     (loadw result function function-self-slot function-pointer-type)
241     (inst lea result
242           (make-ea :byte :base result 
243                    :disp (- function-pointer-type
244                             (* function-code-offset word-bytes))))))
245
246 ;;; Closure function slot is a pointer to raw code on X86 instead of
247 ;;; a pointer to the code function object itself. This VOP is used
248 ;;; to reference the function object given the closure object.
249 (def-source-transform %closure-function (closure)
250   `(%function-self ,closure))
251
252 (def-source-transform %funcallable-instance-function (fin)
253   `(%function-self ,fin))
254
255 (defknown (setf %function-self) (function function) function  (unsafe))
256
257 (define-vop (%set-function-self)
258   (:policy :fast-safe)
259   (:translate (setf %function-self))
260   (:args (new-self :scs (descriptor-reg) :target result :to :result)
261          (function :scs (descriptor-reg) :to :result))
262   (:temporary (:sc any-reg :from (:argument 0) :to :result) temp)
263   (:results (result :scs (descriptor-reg)))
264   (:generator 3
265     (inst lea temp
266           (make-ea :byte :base new-self
267                    :disp (- (ash function-code-offset word-shift)
268                             function-pointer-type)))
269     (storew temp function function-self-slot function-pointer-type)
270     (move result new-self)))
271
272 ;; Would have really liked to use a source-transform for this, but they
273 ;; don't work with setf functions.
274 ;; 
275 (defknown ((setf %funcallable-instance-function)) (function function) function
276   (unsafe))
277 (deftransform (setf %funcallable-instance-function) ((value fin))
278   '(setf (%function-self fin) value))
279
280
281 \f
282 ;;;; Other random VOPs.
283
284 (defknown unix::do-pending-interrupt () (values))
285 (define-vop (unix::do-pending-interrupt)
286   (:policy :fast-safe)
287   (:translate unix::do-pending-interrupt)
288   (:generator 1
289     (inst break pending-interrupt-trap)))
290
291 (define-vop (halt)
292   (:generator 1
293     (inst break halt-trap)))
294
295 (defknown float-wait () (values))
296 (define-vop (float-wait)
297   (:policy :fast-safe)
298   (:translate float-wait)
299   (:vop-var vop)
300   (:save-p :compute-only)
301   (:generator 1
302     (note-next-instruction vop :internal-error)
303     (inst wait)))
304 \f
305 ;;;; Dynamic vop count collection support
306
307 (define-vop (count-me)
308   (:args (count-vector :scs (descriptor-reg)))
309   (:info index)
310   (:generator 0
311     (inst inc (make-ea :dword :base count-vector
312                        :disp (- (* (+ vector-data-offset index) word-bytes)
313                                 other-pointer-type)))))
314
315 \f
316
317 (defknown lisp::%scrub-control-stack () (values))
318
319 ;;; Scrub the control stack.
320 ;;;
321 ;;; On the x86 port the stack grows downwards, and to support grow on
322 ;;; demand stacks the stack must be decreased as it is scrubbed.
323 ;;;
324 (define-vop (%scrub-control-stack)
325   (:policy :fast-safe)
326   (:translate lisp::%scrub-control-stack)
327   (:args)
328   (:results)
329   (:temporary (:sc unsigned-reg) count)
330   (:temporary (:sc any-reg) stack-save zero)
331   (:generator 25
332     (inst mov stack-save esp-tn)
333     (inst mov zero 0)
334     (inst push zero)
335     ;; Scrub the stack.
336     SCRUB
337     (inst add esp-tn 4)
338     (inst mov count 2048)
339     SCRUB-LOOP
340     (inst dec count)
341     (inst push zero)
342     (inst jmp :nz SCRUB-LOOP)
343     ;; Look for a clear stack unit.
344     (inst mov count 2048)
345     LOOK-LOOP
346     (inst sub esp-tn 4)
347     (inst cmp (make-ea :dword :base esp-tn) zero)
348     (inst jmp :ne SCRUB)
349     (inst dec count)
350     (inst jmp :nz LOOK-LOOP)
351     ;; Done, restore the stack pointer.
352     (inst mov esp-tn stack-save)))
353
354 \f
355 ;;;; Primitive multi-thread support.
356
357 (export 'control-stack-fork)
358 (defknown control-stack-fork ((simple-array (unsigned-byte 32) (*)) t)
359   (member t nil))
360
361 (define-vop (control-stack-fork)
362   (:policy :fast-safe)
363   (:translate control-stack-fork)
364   (:args (save-stack :scs (descriptor-reg) :to :result)
365          (inherit :scs (descriptor-reg)))
366   (:arg-types simple-array-unsigned-byte-32 *)
367   (:results (child :scs (descriptor-reg)))
368   (:result-types t)
369   (:temporary (:sc unsigned-reg :from (:eval 0) :to (:eval 1)) index)
370   (:temporary (:sc unsigned-reg :from (:eval 0) :to (:eval 1)) stack)
371   (:temporary (:sc unsigned-reg :from (:eval 0) :to (:eval 1)) temp)
372   (:save-p t)
373   (:generator 25
374     (inst cmp inherit nil-value)
375     (inst jmp :e FRESH-STACK)
376     
377     ;; Child inherits the stack of the parent.
378     
379     ;; Setup the return context.
380     (inst push (make-fixup nil :code-object return))
381     (inst push ebp-tn)
382     ;; Save the stack.
383     (inst xor index index)
384     ;; First the stack-pointer.
385     (inst mov (make-ea :dword :base save-stack :index index :scale 4
386                        :disp (- (* vm:vector-data-offset vm:word-bytes)
387                                 vm:other-pointer-type))
388           esp-tn)
389     (inst inc index)
390     (load-foreign-data-symbol stack "control_stack_end")
391     (inst mov stack (make-ea :dword :base stack))
392     (inst jmp-short LOOP)
393
394     FRESH-STACK
395     ;; Child has a fresh control stack.
396
397     ;; Setup the return context.
398     (inst push (make-fixup nil :code-object return))
399     (load-foreign-data-symbol stack "control_stack_end")
400     (inst mov stack (make-ea :dword :base stack))
401     ;; New FP is the Top of the stack.
402     (inst push stack)
403     ;; Save the stack.
404     (inst xor index index)
405     ;; First save the adjusted stack-pointer.
406     (inst sub stack ebp-tn)
407     (inst add stack esp-tn)
408     (inst mov (make-ea :dword :base save-stack :index index :scale 4
409                        :disp (- (* vm:vector-data-offset vm:word-bytes)
410                                 vm:other-pointer-type))
411           stack)
412     ;; Save the current frame, replacing the OCFP and RA by 0.
413     (inst mov (make-ea :dword :base save-stack :index index :scale 4
414                        :disp (- (* (+ vm:vector-data-offset 1) vm:word-bytes)
415                                 vm:other-pointer-type))
416           0)
417     ;; Save 0 for the OCFP.
418     (inst mov (make-ea :dword :base save-stack :index index :scale 4
419                        :disp (- (* (+ vm:vector-data-offset 2) vm:word-bytes)
420                                 vm:other-pointer-type))
421           0)
422     (inst add index 3)
423     ;; Copy the remainder of the frame, skiping the OCFP and RA which
424     ;; are saved above.
425     (inst lea stack (make-ea :byte :base ebp-tn :disp -8))
426
427     LOOP
428     (inst cmp stack esp-tn)
429     (inst jmp :le stack-save-done)
430     (inst sub stack 4)
431     (inst mov temp (make-ea :dword :base stack))
432     (inst mov (make-ea :dword :base save-stack :index index :scale 4
433                        :disp (- (* vm:vector-data-offset vm:word-bytes)
434                                 vm:other-pointer-type))
435           temp)
436     (inst inc index)
437     (inst jmp-short LOOP)
438     
439     RETURN
440     ;; Stack already clean if it reaches here. Parent returns NIL.
441     (inst mov child nil-value)
442     (inst jmp-short DONE)
443     
444     STACK-SAVE-DONE
445     ;; Cleanup the stack
446     (inst add esp-tn 8)
447     ;; Child returns T.
448     (load-symbol child t)
449     DONE))
450
451 (export 'control-stack-resume)
452 (defknown control-stack-resume ((simple-array (unsigned-byte 32) (*))
453                                 (simple-array (unsigned-byte 32) (*)))
454   (values))
455
456 (define-vop (control-stack-resume)
457   (:policy :fast-safe)
458   (:translate control-stack-resume)
459   (:args (save-stack :scs (descriptor-reg) :to :result)
460          (new-stack :scs (descriptor-reg) :to :result))
461   (:arg-types simple-array-unsigned-byte-32 simple-array-unsigned-byte-32)
462   (:temporary (:sc unsigned-reg :from (:eval 0) :to (:eval 1)) index)
463   (:temporary (:sc unsigned-reg :from (:eval 0) :to (:eval 1)) stack)
464   (:temporary (:sc unsigned-reg :from (:eval 0) :to (:eval 1)) temp)
465   (:save-p t)
466   (:generator 25
467     ;; Setup the return context.
468     (inst push (make-fixup nil :code-object RETURN))
469     (inst push ebp-tn)
470     ;; Save the stack.
471     (inst xor index index)
472     ;; First the stack-pointer.
473     (inst mov (make-ea :dword :base save-stack :index index :scale 4
474                        :disp (- (* vm:vector-data-offset vm:word-bytes)
475                                 vm:other-pointer-type))
476           esp-tn)
477     (inst inc index)
478     (load-foreign-data-symbol stack "control_stack_end")
479     (inst mov stack (make-ea :dword :base stack))
480     LOOP
481     (inst cmp stack esp-tn)
482     (inst jmp :le STACK-SAVE-DONE)
483     (inst sub stack 4)
484     (inst mov temp (make-ea :dword :base stack))
485     (inst mov (make-ea :dword :base save-stack :index index :scale 4
486                        :disp (- (* vm:vector-data-offset vm:word-bytes)
487                                 vm:other-pointer-type))
488           temp)
489     (inst inc index)
490     (inst jmp-short LOOP)
491
492     STACK-SAVE-DONE
493     ;; Cleanup the stack
494     (inst add esp-tn 8)
495
496     ;; Restore the new-stack.
497     (inst xor index index)
498     ;; First the stack-pointer.
499     (inst mov esp-tn
500           (make-ea :dword :base new-stack :index index :scale 4
501                    :disp (- (* vm:vector-data-offset vm:word-bytes)
502                             vm:other-pointer-type)))
503     (inst inc index)
504     (load-foreign-data-symbol stack "control_stack_end")
505     (inst mov stack (make-ea :dword :base stack))
506     LOOP2
507     (inst cmp stack esp-tn)
508     (inst jmp :le STACK-RESTORE-DONE)
509     (inst sub stack 4)
510     (inst mov temp (make-ea :dword :base new-stack :index index :scale 4
511                             :disp (- (* vm:vector-data-offset vm:word-bytes)
512                                      vm:other-pointer-type)))
513     (inst mov (make-ea :dword :base stack) temp)
514     (inst inc index)
515     (inst jmp-short LOOP2)
516     STACK-RESTORE-DONE
517     ;; Pop the frame pointer, and resume at the return address.
518     (inst pop ebp-tn)
519     (inst ret)
520     
521     ;; Original thread resumes, stack has been cleaned up.
522     RETURN))
523
524
525 (export 'control-stack-return)
526 (defknown control-stack-return ((simple-array (unsigned-byte 32) (*)))
527   (values))
528
529 (define-vop (control-stack-return)
530   (:policy :fast-safe)
531   (:translate control-stack-return)
532   (:args (new-stack :scs (descriptor-reg) :to :result))
533   (:arg-types simple-array-unsigned-byte-32)
534   (:temporary (:sc unsigned-reg :from (:eval 0) :to (:eval 1)) index)
535   (:temporary (:sc unsigned-reg :from (:eval 0) :to (:eval 1)) stack)
536   (:temporary (:sc unsigned-reg :from (:eval 0) :to (:eval 1)) temp)
537   (:save-p t)
538   (:generator 25
539     ;; Restore the new-stack.
540     (inst xor index index)
541     ;; First the stack-pointer.
542     (inst mov esp-tn
543           (make-ea :dword :base new-stack :index index :scale 4
544                    :disp (- (* vm:vector-data-offset vm:word-bytes)
545                             vm:other-pointer-type)))
546     (inst inc index)
547     (load-foreign-data-symbol stack "control_stack_end")
548     (inst mov stack (make-ea :dword :base stack))
549     LOOP
550     (inst cmp stack esp-tn)
551     (inst jmp :le STACK-RESTORE-DONE)
552     (inst sub stack 4)
553     (inst mov temp (make-ea :dword :base new-stack :index index :scale 4
554                             :disp (- (* vm:vector-data-offset vm:word-bytes)
555                                      vm:other-pointer-type)))
556     (inst mov (make-ea :dword :base stack) temp)
557     (inst inc index)
558     (inst jmp-short LOOP)
559     STACK-RESTORE-DONE
560     ;; Pop the frame pointer, and resume at the return address.
561     (inst pop ebp-tn)
562     (inst ret)))
563
564
565 ;; The RDTSC instruction (present on Pentium processors and
566 ;; successors) allows you to access the time-stamp counter, a 64-bit
567 ;; model-specific register that counts executed cycles. The
568 ;; instruction returns the low cycle count in EAX and high cycle count
569 ;; in EDX.
570 ;;
571 ;; In order to obtain more significant results on out-of-order
572 ;; processors (such as the Pentium II and later), we issue a
573 ;; serializing CPUID instruction before reading the cycle counter.
574 ;; This instruction is used for its side effect of emptying the
575 ;; processor pipeline, to ensure that the RDTSC instruction is
576 ;; executed once all pending instructions have been completed.
577 ;;
578 ;; Note that cache effects mean that the cycle count can vary for
579 ;; different executions of the same code (it counts cycles, not
580 ;; retired instructions). Furthermore, the results are per-processor
581 ;; and not per-process, so are unreliable on multiprocessor machines
582 ;; where processes can migrate between processors.
583 ;;
584 ;; This method of obtaining a cycle count has the advantage of being
585 ;; very fast (around 20 cycles), and of not requiring a system call.
586 ;; However, you need to know your processor's clock speed to translate
587 ;; this into real execution time.
588
589 (defknown read-cycle-counter () (values (unsigned-byte 32) (unsigned-byte 32)) ())
590
591 (define-vop (read-cycle-counter)
592   (:translate read-cycle-counter)
593   (:guard (backend-featurep :pentium))
594   (:args )
595   (:policy :fast-safe)
596   (:results (lo :scs (unsigned-reg))
597             (hi :scs (unsigned-reg)))
598   (:result-types unsigned-num unsigned-num)
599   (:temporary (:sc unsigned-reg :offset eax-offset :target lo) eax)
600   (:temporary (:sc unsigned-reg :offset edx-offset :target hi) edx)
601   ;; CPUID writes to eax, ebx, ecx, and edx.  We need temporaries for
602   ;; ebx and ecx so we don't destroy any live uses of ebx and ecx.
603   (:temporary (:sc unsigned-reg :offset ebx-offset
604                    :from (:eval 0) :to (:result 1))
605               ebx)
606   (:temporary (:sc unsigned-reg :offset ecx-offset
607                    :from (:eval 0) :to (:result 2))
608               ecx)
609   (:ignore ebx ecx)
610   (:generator 1
611     (inst mov eax 0)
612     (inst cpuid)
613     (inst rdtsc)
614     (move hi edx)
615     (move lo eax)))
616
617 #+pentium
618 (defun read-cycle-counter ()
619   (read-cycle-counter))
620
621 (defknown cpuid ((unsigned-byte 32))
622   (values (unsigned-byte 32)
623           (unsigned-byte 32)
624           (unsigned-byte 32)
625           (unsigned-byte 32))
626   ())
627
628 (define-vop (cpuid)
629   (:policy :fast-safe)
630   (:translate cpuid)
631   (:args (level :scs (unsigned-reg) :to (:eval 0)))
632   (:arg-types unsigned-num)
633   (:results (a :scs (unsigned-reg))
634             (b :scs (unsigned-reg))
635             (c :scs (unsigned-reg))
636             (d :scs (unsigned-reg)))
637   (:result-types unsigned-num unsigned-num unsigned-num unsigned-num)
638   ;; Not sure about these :from/:to values.
639   (:temporary (:sc unsigned-reg :offset eax-offset
640                    :from (:eval 0) :to (:result 0))
641               eax)
642   (:temporary (:sc unsigned-reg :offset ebx-offset
643                    :from (:eval 0) :to (:result 1))
644               ebx)
645   (:temporary (:sc unsigned-reg :offset ecx-offset
646                    :from (:eval 0) :to (:result 2))
647               ecx)
648   (:temporary (:sc unsigned-reg :offset edx-offset
649                    :from (:eval 0) :to (:result 3))
650               edx)
651   (:temporary (:sc unsigned-stack :from (:eval 0) :to (:result 0)) eax-stack)
652   (:temporary (:sc unsigned-stack :from (:eval 0) :to (:result 1)) ebx-stack)
653   (:temporary (:sc unsigned-stack :from (:eval 0) :to (:result 2)) ecx-stack)
654   (:temporary (:sc unsigned-stack :from (:eval 0) :to (:result 3)) edx-stack)
655   (:generator 10
656     (move eax level)
657     (inst cpuid)
658     ;; Don't know where a, b, c, d are, so we save the results of
659     ;; cpuid to the stack and then copy the stack values to the result
660     ;; registers.  But we can skip this if the result registers match
661     ;; the output registers of the cpuid instruction.
662     (unless (and (location= eax a)
663                  (location= ebx b)
664                  (location= ecx c)
665                  (location= edx d))
666       (move eax-stack eax)
667       (move ebx-stack ebx)
668       (move ecx-stack ecx)
669       (move edx-stack edx)
670       (move a eax-stack)
671       (move b ebx-stack)
672       (move c ecx-stack)
673       (move d edx-stack))))
674       
675              
676 (defun cpuid (level)
677   (declare (type (unsigned-byte 32) level))
678   (cpuid level))
679
680 (defmacro with-cycle-counter (&body body)
681   "Returns the primary value of BODY as the primary value, and the
682  number of CPU cycles elapsed as secondary value."
683   (let ((hi0 (gensym))
684         (hi1 (gensym))
685         (lo0 (gensym))
686         (lo1 (gensym)))
687     `(multiple-value-bind (,lo0 ,hi0)
688          (read-cycle-counter)
689        (values (locally ,@body)
690                (multiple-value-bind (,lo1 ,hi1)
691                    (read-cycle-counter)
692                  ;; Can't do anything about the notes about generic
693                  ;; arithmetic, so silence the notes..
694                  (declare (optimize (inhibit-warnings 3))
695                  (+ (ash (- ,hi1 ,hi0) 32)
696                     (- ,lo1 ,lo0)))))))