src/code/x86-cpuid.lisp

   1 ;;;; CPUID handling for X86-based systems
   2
   3 (in-package "SB!VM")
   4 \f
   5 (defun u32-to-string (&rest rest)
   6   (loop
   7     with length = (length rest)
   8     with result = (make-string (* 4 length))
   9     for i from 0 by 4
  10     for u32 in rest
  11     do (loop
  12          for j from 0 below 4
  13          do (setf (char result (+ i j)) (code-char (ldb (byte 8 (* j 8)) u32))))
  14     finally (return result)))
  15
  16 (defparameter *cpuid-vendor-ids*
  17   '(("AMDisbetter!" :oldamd)
  18     ("AuthenticAMD" :amd)
  19     ("GenuineIntel" :intel)
  20     ("CentaurHauls" :via)
  21     ("TransmetaCPU" :oldtransmeta)
  22     ("GenuineTMx86" :transmeta)
  23     ("CyrixInstead" :cyrix)
  24     ("CentaurHauls" :centaur)
  25     ("NexGenDriven" :nexgen)
  26     ("UMC UMC UMC " :umc)
  27     ("SiS SiS SiS " :sis)
  28     ("Geode by NSC" :nsc)
  29     ("RiseRiseRise" :rise)
  30     ("VIA VIA VIA " :via)
  31     ("Vortex86 SoC" :vortex)
  32     ("KVMKVMKVMKVM" :kvm)
  33     ("Microsoft Hv" :hyperv)
  34     ("VMwareVMware" :vmware)
  35     ("XenVMMXenVMM" :xen)))
  36
  37 (defun %cpuid (eax &optional (ebx 0) (ecx 0) (edx 0))
  38   (%cpuid/4 eax ebx ecx edx))
  39
  40 (defun cpuid-highest-parameter ()
  41   (values (%cpuid 0)))
  42
  43 (defun cpuid-highest-extended-parameter ()
  44   (values (%cpuid #x80000000)))
  45
  46 (defun cpuid-vendor-id ()
  47   (multiple-value-bind (eax ebx ecx edx)
  48       (%cpuid 0)
  49     (let ((decoded (u32-to-string ebx edx ecx)))
  50       (values (cadr (assoc decoded *cpuid-vendor-ids* :test #'string=)) decoded eax))))
  51
  52 (defparameter *cpuid-feature-flags*
  53   '((:fpu    :vme    :de     :pse
  54      :tsc    :msr    :pae    :mce
  55      :cx8    :apic   NIL     :sep
  56      :mtrr   :pge    :mca    :cmov
  57      :pat    :pse36  :psn    :clfl
  58      NIL     :dtes   :acpi   :mmx
  59      :fxsr   :sse    :sse2   :ss
  60      :htt    :tm1    :ia-64  :pbe)
  61     (:sse3   :pclmul :dtes64 :mon
  62      :dspcl  :vmx    :smx    :est
  63      :tm2    :ssse3  :cid    NIL
  64      :fma    :cx16   :etprd  :pdcm
  65      NIL     :pcid   :dca    :sse4.1
  66      :sse4.2 :x2apic :movbe  :popcnt
  67      :tscd   :aes    :xsave  :osxsave
  68      :avx    :f16c   :rdrand NIL)))
  69
  70 (defun decode-cpuid-feature-flags (value flags)
  71   (let (result (i 0))
  72     (dolist (flag flags result)
  73       (when (and flag (logbitp i value))
  74         (push flag result))
  75       (incf i))))
  76
  77 (defun decode-cpuid-processor-info (vendor eax)
  78   (let ((stepping (ldb (byte 4 0) eax))
  79         (model (ldb (byte 4 4) eax))
  80         (family (ldb (byte 4 8) eax))
  81         (processor-type (ldb (byte 2 12) eax))
  82         (extended-model (ldb (byte 4 16) eax))
  83         (extended-family (ldb (byte 4 20) eax)))
  84     (flet ((intel ()
  85              (list stepping
  86                    (+ model (ash extended-model 4))
  87                    (+ family extended-family)
  88                    processor-type)))
  89       (case vendor
  90         ((:oldamd :amd)
  91          (if (eql family 15)
  92              (intel)
  93              (list stepping model family processor-type)))
  94         (T
  95          (intel))))))
  96
  97 (defun cpuid-signature (&optional (vendor-id (cpuid-vendor-id)))
  98   (when (< (cpuid-highest-parameter) 1)
  99     (warn "Processor info feature unsupported by CPU.")
 100     (return-from cpuid-signature))
 101   (multiple-value-bind (eax ebx ecx edx)
 102       (%cpuid 1)
 103     (values
 104      (append (decode-cpuid-feature-flags edx (car *cpuid-feature-flags*))
 105              (decode-cpuid-feature-flags ecx (cadr *cpuid-feature-flags*)))
 106      (decode-cpuid-processor-info vendor-id eax))))
 107
 108 (defun cpuid-processor-name ()
 109   (when (< (cpuid-highest-extended-parameter) #x80000004)
 110     (warn "Processor name feature unsupported by CPU.")
 111     (return-from cpuid-processor-name))
 112   (string-trim
 113    '(#\Space #\Nul)
 114    (multiple-value-call #'u32-to-string
 115      (%cpuid #x80000002)
 116      (%cpuid #x80000003)
 117      (%cpuid #x80000004))))
 118
 119 (defun cpuid (what)
 120   (unless (cpuid-available-p)
 121     (warn "CPUID instruction unsupported by CPU.")
 122     (return-from cpuid))
 123   (ecase what
 124    (:vendor-id (cpuid-vendor-id))
 125    (:signature (cpuid-signature))
 126    (:processor-name (cpuid-processor-name))))