edd4aada768db2a53aa67b1447de5c6eaf7dae5c
[projects/cmucl/cmucl.git] / src / compiler / x86 / system.lisp
1 ;;; -*- 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   (:generator 1
602      (inst cpuid)
603      (inst rdtsc)
604      (move hi edx)
605      (move lo eax)))
606
607 #+pentium
608 (defun read-cycle-counter ()
609   (read-cycle-counter))
610
611 (defknown cpuid ((unsigned-byte 32))
612   (values (unsigned-byte 32)
613           (unsigned-byte 32)
614           (unsigned-byte 32)
615           (unsigned-byte 32))
616   ())
617
618 (define-vop (cpuid)
619   (:policy :fast-safe)
620   (:translate cpuid)
621   (:args (level :scs (unsigned-reg) :to (:eval 0)))
622   (:arg-types unsigned-num)
623   (:results (a :scs (unsigned-reg))
624             (b :scs (unsigned-reg))
625             (c :scs (unsigned-reg))
626             (d :scs (unsigned-reg)))
627   (:result-types unsigned-num unsigned-num unsigned-num unsigned-num)
628   ;; Not sure about these :from/:to values.
629   (:temporary (:sc unsigned-reg :offset eax-offset
630                    :from (:eval 0) :to (:result 0))
631               eax)
632   (:temporary (:sc unsigned-reg :offset ebx-offset
633                    :from (:eval 0) :to (:result 1))
634               ebx)
635   (:temporary (:sc unsigned-reg :offset ecx-offset
636                    :from (:eval 0) :to (:result 2))
637               ecx)
638   (:temporary (:sc unsigned-reg :offset edx-offset
639                    :from (:eval 0) :to (:result 3))
640               edx)
641   (:temporary (:sc unsigned-stack :from (:eval 0) :to (:result 0)) eax-stack)
642   (:temporary (:sc unsigned-stack :from (:eval 0) :to (:result 1)) ebx-stack)
643   (:temporary (:sc unsigned-stack :from (:eval 0) :to (:result 2)) ecx-stack)
644   (:temporary (:sc unsigned-stack :from (:eval 0) :to (:result 3)) edx-stack)
645   (:generator 10
646     (move eax level)
647     (inst cpuid)
648     ;; Don't know where a, b, c, d are, so we save the results of
649     ;; cpuid to the stack and then copy the stack values to the result
650     ;; registers.  But we can skip this if the result registers match
651     ;; the output registers of the cpuid instruction.
652     (unless (and (location= eax a)
653                  (location= ebx b)
654                  (location= ecx c)
655                  (location= edx d))
656       (move eax-stack eax)
657       (move ebx-stack ebx)
658       (move ecx-stack ecx)
659       (move edx-stack edx)
660       (move a eax-stack)
661       (move b ebx-stack)
662       (move c ecx-stack)
663       (move d edx-stack))))
664       
665              
666 (defun cpuid (level)
667   (declare (type (unsigned-byte 32) level))
668   (cpuid level))