cpuid.lisp

   1 (defpackage :cpuid (:use :cl))
   2 (in-package :cpuid)
   3
   4
   5 (defvar +cpu-std-feat-fields+
   6   #(:fpu :vme :de :pse :tsc :k86-msr :pae :mce :cmpxchg8b :apic :res10 :sysenter/exit :mtrr :gpe :mca :cmov :pat :pse-36 :psn :clflush :res20 :ds :acpi :mmx :fxsave/rstor :sse :sse2 :self-snoop :htt :tm :res30 :pbe))
   7
   8 (defvar +cpu-std-feat-fields-ecx+
   9   #(:sse3 :res1 :res2 :monitor :ds-cpl :res5 :res6 :eist :tm2 :res9 :cid :res11 :res12 :cmpxchg16b :stpm :res14 :res15
  10     0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0))
  11
  12 ;; low bits are mostly same as in std-feat, so skip them..
  13 (defvar +cpu-ext-feat-fields+
  14   #(0 1 2 3 4 5 6 7 8 9 10 :syscall/ret 12 13 14 15 16 17 18 19 :nx 21 :mmx-ext :mmx 24 25 26 27 28 :longmode/em64t :3dnow-ext :3dnow))
  15
  16
  17 (defvar *cpu-features* nil)
  18 (defvar *cpu-vendor* nil) ;; eg authenticamd
  19 (defvar *cpu-name* nil) ;; eg AMD Athlon XP
  20 (defvar *cpu-cache* nil)
  21
  22
  23 (defun inspect-cpu ()
  24
  25   (let ((array (make-array 8 :element-type '(unsigned-byte 16) :initial-element 0)) c d)
  26
  27     ;; vendor
  28
  29     (sb-sys:%primitive sb-vm::%read-cpu/x86 #x00000000 array)
  30
  31     (let ((temp (make-array 12 :element-type '(unsigned-byte 8) :initial-element 0)))
  32       (flet ((load-word (i u v) (setf (aref temp (+ i 3)) (ash (aref array u) -8)
  33                                       (aref temp (+ i 2)) (logand (aref array u) 255)
  34                                       (aref temp (+ i 1)) (ash (aref array v) -8)
  35                                       (aref temp (+ i 0)) (logand (aref array v) 255))))
  36       (loop for i from 0 below 12 by 4
  37             for (u v) in '((2 3) (6 7) (4 5))
  38             do (load-word i u v))
  39
  40       (setq *cpu-vendor* (map 'string #'code-char temp))))
  41
  42
  43     ;; std features
  44     (setq *cpu-features* nil)
  45
  46     (sb-sys:%primitive sb-vm::%read-cpu/x86 #x00000001 array)
  47
  48     (setq
  49 ;;     a (logior (ash (aref array 0) 16) (aref array 1))
  50 ;;     b (logior (ash (aref array 2) 16) (aref array 3))
  51      c (logior (ash (aref array 4) 16) (aref array 5))
  52      d (logior (ash (aref array 6) 16) (aref array 7)))
  53
  54     (loop for i from 0 below 32 do
  55           (if (= (ldb (byte 1 i) d) 1)
  56               (push (aref +cpu-std-feat-fields+ i) *cpu-features*)))
  57
  58     (loop for i from 0 below 32 do
  59           (if (= (ldb (byte 1 i) c) 1)
  60               (push (aref +cpu-std-feat-fields-ecx+ i) *cpu-features*))))
  61   )
  62
  63 (defun inspect-cpu-ext ()
  64   (let ((array (make-array 8 :element-type '(unsigned-byte 16) :initial-element 0))
  65         c d (max-ext-func 0))
  66
  67     ;; determine max ext func
  68     (sb-sys:%primitive sb-vm::%read-cpu/x86 #x80000000 array)
  69     (setq max-ext-func (logior (ash (aref array 0) 16) (aref array 1)))
  70
  71     ;; ext features (AMD/Intel)
  72     (if (>= max-ext-func #x80000001)
  73         (progn
  74           (sb-sys:%primitive sb-vm::%read-cpu/x86 #x80000001 array)
  75           (setq d (logior (ash (aref array 6) 16) (aref array 7)))
  76
  77           (loop for i from 0 below 32 do
  78                 (let ((flag (ldb (byte 1 i) d))
  79                       (feat (aref +cpu-ext-feat-fields+ i)))
  80                   (if (and (= flag 1) (keywordp feat))
  81                       (pushnew feat *cpu-features*))))))
  82
  83     ;; cpu name (AMD/Intel)
  84     (setq *cpu-name* nil)
  85     (if (>= max-ext-func #x80000004)
  86         (let ((cpuname #())
  87               (temp (make-array 16 :element-type '(unsigned-byte 8) :initial-element 0)))
  88           (flet ((load-word (i u v) (setf (aref temp (+ i 3)) (ash (aref array u) -8)
  89                                           (aref temp (+ i 2)) (logand (aref array u) 255)
  90                                           (aref temp (+ i 1)) (ash (aref array v) -8)
  91                                           (aref temp (+ i 0)) (logand (aref array v) 255))))
  92             (flet ((conc-word ()
  93                      (loop for i from 0 below 16 by 4
  94                            for (u v) in '((0 1) (2 3) (4 5) (6 7))
  95                            do
  96                            (load-word i u v))
  97                      (setq cpuname (concatenate '(simple-array (unsigned-byte 8) (*)) cpuname temp))))
  98
  99               (sb-sys:%primitive sb-vm::%read-cpu/x86 #x80000002 array) (conc-word)
 100               (sb-sys:%primitive sb-vm::%read-cpu/x86 #x80000003 array) (conc-word)
 101               (sb-sys:%primitive sb-vm::%read-cpu/x86 #x80000004 array) (conc-word)
 102               ))
 103
 104           ;; cut to null
 105           (if (position 0 cpuname)
 106               (setq cpuname (subseq cpuname 0 (position 0 cpuname))))
 107           ;; coerce to string
 108           (setq cpuname (map 'string #'code-char cpuname))
 109           (setq *cpu-name* cpuname)))
 110
 111     ;; cache (AMD)
 112     (setq *cpu-cache* nil)
 113     (if (>= max-ext-func #x80000005)
 114         (progn
 115           (sb-sys:%primitive sb-vm::%read-cpu/x86 #x80000005 array)
 116           (setq c (logior (ash (aref array 4) 16) (aref array 5))
 117                 d (logior (ash (aref array 6) 16) (aref array 7)))
 118
 119           (push (list :l1-data :size (* 1024 (ldb (byte 8 24) c))) *cpu-cache*)
 120           (push (list :l1-inst :size (* 1024 (ldb (byte 8 24) d))) *cpu-cache*)))
 121
 122
 123     (if (>= max-ext-func #x80000006)
 124         (progn
 125           (sb-sys:%primitive sb-vm::%read-cpu/x86 #x80000006 array)
 126           (setq c (logior (ash (aref array 4) 16) (aref array 5)))
 127           (push (list :l2 :size (* 1024 (ldb (byte 16 16) c))) *cpu-cache*)))
 128
 129     t))
 130
 131 (defun dump-cpu ()
 132
 133     ;; dump
 134
 135     (format t "~&")
 136     (format t "Vendor: ~A.~%" *cpu-vendor*)
 137     (format t "Features: ~S.~%" *cpu-features*)
 138     (format t "cpu: ~A, cache: ~S.~%" *cpu-name* *cpu-cache*)
 139     )