Check for CPUID availability, better parsing.

Also added processor info parsing and checks against highest parameter levels
(standard and extended).

diff --git a/src/code/x86-cpuid.lisp b/src/code/x86-cpuid.lisp
index f9d37f0..5607310 100644 (file)
--- a/src/code/x86-cpuid.lisp
+++ b/src/code/x86-cpuid.lisp
@@ -26,31 +26,46 @@
     ("UMC UMC UMC " :umc)
     ("SiS SiS SiS " :sis)
     ("Geode by NSC" :nsc)
-    ("RiseRiseRise" :rise)))
+    ("RiseRiseRise" :rise)
+    ("VIA VIA VIA " :via)
+    ("Vortex86 SoC" :vortex)
+    ("KVMKVMKVMKVM" :kvm)
+    ("Microsoft Hv" :hyperv)
+    ("VMwareVMware" :vmware)
+    ("XenVMMXenVMM" :xen)))
+
+(defun %cpuid (eax &optional (ebx 0) (ecx 0) (edx 0))
+  (%cpuid/4 eax ebx ecx edx))
+
+(defun cpuid-highest-parameter ()
+  (values (%cpuid 0)))
+
+(defun cpuid-highest-extended-parameter ()
+  (values (%cpuid #x80000000)))
 
 (defun cpuid-vendor-id ()
   (multiple-value-bind (eax ebx ecx edx)
-      (%cpuid/4 0 0 0 0)
+      (%cpuid 0)
     (let ((decoded (u32-to-string ebx edx ecx)))
-      (values eax (cadr (assoc decoded *cpuid-vendor-ids* :test #'string=)) decoded))))
+      (values (cadr (assoc decoded *cpuid-vendor-ids* :test #'string=)) decoded eax))))
 
 (defparameter *cpuid-feature-flags*
-  '((:sse3 :pclmul :dtes64 :mon
-     :dspcl :vmx :smx :est
-     :tm2 :ssse3 :cid NIL
-     :fma :cx16 :etprd :pdcm
-     NIL :pcid :dca :sse4.1
-     sse4.2 :x2apic :movbe :popcnt
-     :tscd :aes :xsave :osxsave
-     :avx :f16c :rdrand NIL)
-    (:fpu :vme :de :pse
-     :tsc :msr :pae :mce
-     :cx8 :apic NIL :sep
-     :mtrr :pge :mca :cmov
-     :pat :pse36 :psn :clfl
-     NIL :dtes :acpi :mmx
-     :fxsr :sse :sse2 :ss
-     :htt :tm1 :ia-64 :pbe)))
+  '((:fpu    :vme    :de     :pse
+     :tsc    :msr    :pae    :mce
+     :cx8    :apic   NIL     :sep
+     :mtrr   :pge    :mca    :cmov
+     :pat    :pse36  :psn    :clfl
+     NIL     :dtes   :acpi   :mmx
+     :fxsr   :sse    :sse2   :ss
+     :htt    :tm1    :ia-64  :pbe)
+    (:sse3   :pclmul :dtes64 :mon
+     :dspcl  :vmx    :smx    :est
+     :tm2    :ssse3  :cid    NIL
+     :fma    :cx16   :etprd  :pdcm
+     NIL     :pcid   :dca    :sse4.1
+     :sse4.2 :x2apic :movbe  :popcnt
+     :tscd   :aes    :xsave  :osxsave
+     :avx    :f16c   :rdrand NIL)))
 
 (defun decode-cpuid-feature-flags (value flags)
   (let (result (i 0))
@@ -59,27 +74,52 @@
         (push flag result))
       (incf i))))
 
-(defun cpuid-signature ()
+(defun decode-cpuid-processor-info (vendor eax)
+  (let ((stepping (ldb (byte 4 0) eax))
+        (model (ldb (byte 4 4) eax))
+        (family (ldb (byte 4 8) eax))
+        (processor-type (ldb (byte 2 12) eax))
+        (extended-model (ldb (byte 4 16) eax))
+        (extended-family (ldb (byte 4 20) eax)))
+    (flet ((intel ()
+             (list stepping
+                   (+ model (ash extended-model 4))
+                   (+ family extended-family)
+                   processor-type)))
+      (case vendor
+        ((:oldamd :amd)
+         (if (eql family 15)
+             (intel)
+             (list stepping model family processor-type)))
+        (T
+         (intel))))))
+
+(defun cpuid-signature (&optional (vendor-id (cpuid-vendor-id)))
+  (when (< (cpuid-highest-parameter) 1)
+    (warn "Processor info feature unsupported by CPU.")
+    (return-from cpuid-signature))
   (multiple-value-bind (eax ebx ecx edx)
-      (%cpuid/4 1 0 0 0)
-    (let (flags)
-      (values
-       ;; (ldb (byte 4 0) eax) ; stepping
-       ;; (ldb (byte 4 4) eax) ; model
-       ;; (ldb (byte 4 8) eax) ; family
-       (append (decode-cpuid-feature-flags ecx (car *cpuid-feature-flags*))
-               (decode-cpuid-feature-flags edx (cadr *cpuid-feature-flags*)))
-       flags))))
+      (%cpuid 1)
+    (values
+     (append (decode-cpuid-feature-flags edx (car *cpuid-feature-flags*))
+             (decode-cpuid-feature-flags ecx (cadr *cpuid-feature-flags*)))
+     (decode-cpuid-processor-info vendor-id eax))))
 
 (defun cpuid-processor-name ()
-  (string-trim '(#\Space #\0)
-   (concatenate
-    'string
-    (multiple-value-call #'u32-to-string (%cpuid/4 #x80000002 0 0 0))
-    (multiple-value-call #'u32-to-string (%cpuid/4 #x80000003 0 0 0))
-    (multiple-value-call #'u32-to-string (%cpuid/4 #x80000004 0 0 0)))))
+  (when (< (cpuid-highest-extended-parameter) #x80000004)
+    (warn "Processor name feature unsupported by CPU.")
+    (return-from cpuid-processor-name))
+  (string-trim
+   '(#\Space #\Nul)
+   (multiple-value-call #'u32-to-string
+     (%cpuid #x80000002)
+     (%cpuid #x80000003)
+     (%cpuid #x80000004))))
 
 (defun cpuid (what)
+  (unless (cpuid-available-p)
+    (warn "CPUID instruction unsupported by CPU.")
+    (return-from cpuid))
   (ecase what
    (:vendor-id (cpuid-vendor-id))
    (:signature (cpuid-signature))

diff --git a/src/compiler/x86/system.lisp b/src/compiler/x86/system.lisp
index 9834711..8726a6e 100644 (file)
--- a/src/compiler/x86/system.lisp
+++ b/src/compiler/x86/system.lisp
@@ -288,6 +288,39 @@
     (note-next-instruction vop :internal-error)
     (inst wait)))
 \f
+;;;; CPUID detection
+
+(defknown %cpuid-available-p () (values boolean))
+(define-vop (%cpuid-available-p)
+  (:policy :fast-safe)
+  (:translate %cpuid-available-p)
+  (:results (result :scs (descriptor-reg)))
+  (:result-types *)                     ; should be BOOLEAN
+  (:temporary (:sc unsigned-reg :offset eax-offset :target result) eax)
+  (:temporary (:sc unsigned-reg :offset ecx-offset) ecx)
+  (:generator 15
+    (inst pushf)
+    (inst pop eax)
+    (inst mov ecx eax)
+    (inst xor eax #x200000)
+    (inst push eax)
+    (inst popf)
+    (inst pushf)
+    (inst pop eax)
+    (inst push ecx)
+    (inst popf)
+    (inst xor eax ecx)
+    (inst test eax #x200000)
+    (inst jmp :z UNSUPPORTED)
+    (load-symbol result t)
+    (inst jmp DONE)
+    UNSUPPORTED
+    (inst mov result nil-value)
+    DONE))
+
+(defun cpuid-available-p ()
+  (%cpuid-available-p))
+\f
 ;;;; Miscellany
 
 ;;; the RDTSC instruction (present on Pentium processors and
@@ -359,12 +392,10 @@ number of CPU cycles elapsed as secondary value. EXPERIMENTAL."
     (inst inc (make-ea-for-vector-data count-vector :offset index))))
 \f
 ;;;; CPUID parsing
+
 (defknown %cpuid/4 ((unsigned-byte 32) (unsigned-byte 32) (unsigned-byte 32) (unsigned-byte 32))
   (values (unsigned-byte 32) (unsigned-byte 32) (unsigned-byte 32) (unsigned-byte 32)) ())
 
-;; TODO: make argument-2-4 optional?
-;; TODO: check eflags for cpuid?
-;; TODO: guard against unavailable cpuid?
 (define-vop (%cpuid/4)
   (:policy :fast-safe)
   (:translate %cpuid/4)
@@ -382,7 +413,7 @@ number of CPU cycles elapsed as secondary value. EXPERIMENTAL."
             (result-3 :scs (unsigned-reg))
             (result-4 :scs (unsigned-reg)))
   (:result-types unsigned-num unsigned-num unsigned-num unsigned-num)
-  (:generator 3
+  (:generator 9
     (move eax argument-1)
     (move ebx argument-2)
     (move ecx argument-3)