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))