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
  31 (defun cpuid-vendor-id ()
  32   (multiple-value-bind (eax ebx ecx edx)
  33       (%cpuid/4 0 0 0 0)
  34     (let ((decoded (u32-to-string ebx edx ecx)))
  35       (values eax (cadr (assoc decoded *cpuid-vendor-ids* :test #'string=)) decoded))))
  36
  37 (defparameter *cpuid-feature-flags*
  38   '((:sse3 :pclmul :dtes64 :mon
  39      :dspcl :vmx :smx :est
  40      :tm2 :ssse3 :cid NIL
  41      :fma :cx16 :etprd :pdcm
  42      NIL :pcid :dca :sse4.1
  43      sse4.2 :x2apic :movbe :popcnt
  44      :tscd :aes :xsave :osxsave
  45      :avx :f16c :rdrand NIL)
  46     (:fpu :vme :de :pse
  47      :tsc :msr :pae :mce
  48      :cx8 :apic NIL :sep
  49      :mtrr :pge :mca :cmov
  50      :pat :pse36 :psn :clfl
  51      NIL :dtes :acpi :mmx
  52      :fxsr :sse :sse2 :ss
  53      :htt :tm1 :ia-64 :pbe)))
  54
  55 (defun decode-cpuid-feature-flags (value flags)
  56   (let (result (i 0))
  57     (dolist (flag flags result)
  58       (when (and flag (logbitp i value))
  59         (push flag result))
  60       (incf i))))
  61
  62 (defun cpuid-signature ()
  63   (multiple-value-bind (eax ebx ecx edx)
  64       (%cpuid/4 1 0 0 0)
  65     (let (flags)
  66       (values
  67        ;; (ldb (byte 4 0) eax) ; stepping
  68        ;; (ldb (byte 4 4) eax) ; model
  69        ;; (ldb (byte 4 8) eax) ; family
  70        (append (decode-cpuid-feature-flags ecx (car *cpuid-feature-flags*))
  71                (decode-cpuid-feature-flags edx (cadr *cpuid-feature-flags*)))
  72        flags))))
  73
  74 (defun cpuid-processor-name ()
  75   (string-trim '(#\Space #\0)
  76    (concatenate
  77     'string
  78     (multiple-value-call #'u32-to-string (%cpuid/4 #x80000002 0 0 0))
  79     (multiple-value-call #'u32-to-string (%cpuid/4 #x80000003 0 0 0))
  80     (multiple-value-call #'u32-to-string (%cpuid/4 #x80000004 0 0 0)))))
  81
  82 (defun cpuid (what)
  83   (ecase what
  84    (:vendor-id (cpuid-vendor-id))
  85    (:signature (cpuid-signature))
  86    (:processor-name (cpuid-processor-name))))