SBCLでCPUID

Shibuya.lisp TT#4で,S式でアセンブラを書いていたhigepon氏が格好良かった。アセンブラを書くまではいかなくとも、アセンブラの命令を呼ぶくらいはやってみたいと思い、 SBCLでCPUID命令を実行してみた。

最初はバイナリコード+FFI(Foreign Function Interface)でなんとかしようかとも思ったけど、バイナリコードを吐くためにアセンブラを使う方法しか思い浮かばなかったので却下した。

SBCLにはネイティブコードコンパイラがついているのだから、なんとかしてSBCLの世界だけで CPUID命令を実行するところまでいきたい。

で、SBCL internalsなる記事で調べてみたところ、VOP(Virtual Operation)というものを使えばなんとかなりそうだとわかった。 (define-instruction cpuid ...)というのがあるので、幸いにもcpuid命令のバイナリコードは定義してあるようだ。

英語を読むパワーがないので、例のごとくとりあえず動くというだけのコードになった。まあ、動くからいいや。

処理系はSBCL 1.0.30 (ubuntu-VM上).

(sb-c:defknown common-lisp-user::%cpu-id
    ;;arg-types
    ((unsigned-byte 32) (unsigned-byte 32))
    ;;result-type
    (unsigned-byte 32)
    ())

(sb-c:define-vop (%cpu-id)
  (:policy :fast-safe)
  (:args (eax-val :scs (sb-vm::unsigned-reg sb-vm::immediate))
	 (arg :scs (sb-vm::any-reg sb-vm::immediate)))
  (:arg-types sb-vm::positive-fixnum sb-vm::positive-fixnum)
  (:translate %cpu-id)
  (:temporary (:sc sb-vm::unsigned-reg :offset sb-vm::eax-offset) eax)
  (:temporary (:sc sb-vm::unsigned-reg :offset sb-vm::edx-offset) edx)
  (:temporary (:sc sb-vm::unsigned-reg :offset sb-vm::ecx-offset) ecx)
  (:temporary (:sc sb-vm::unsigned-reg :offset sb-vm::ebx-offset) ebx)
  (:results
   (r1 :scs (sb-vm::unsigned-reg)))
  (:result-types sb-vm::unsigned-num)
  (:generator
   8
   (sb-vm::sc-case eax-val
     (sb-vm::immediate
      (sb-assem:inst mov eax (sb-vm::tn-value eax-val)))
     (T (sb-c:move eax eax-val)))

   (sb-assem:inst cpuid)

   (sb-vm::sc-case arg
       (sb-vm::immediate
	(cond
	  ((= (sb-vm::tn-value arg) sb-vm::ebx-offset) (sb-c:move r1 ebx))
	  ((= (sb-vm::tn-value arg) sb-vm::ecx-offset) (sb-c:move r1 ecx))
	  ((= (sb-vm::tn-value arg) sb-vm::edx-offset) (sb-c:move r1 edx))
	  (T (sb-c:move r1 eax))))
       (T (sb-c:move r1 eax)))))

;;(sb-c::%primitive %cpu-id 0 sb-vm::ebx-offset)

(defun word->byte-list (n)
  (list
   (ldb (byte 8 24) n)
   (ldb (byte 8 16) n)
   (ldb (byte 8 8) n)
   (ldb (byte 8 0) n)))

(defun get-cpu-vender ()
  (let ((ebx (sb-c::%primitive %cpu-id 0 sb-vm::ebx-offset))
	(ecx (sb-c::%primitive %cpu-id 0 sb-vm::ecx-offset))
	(edx (sb-c::%primitive %cpu-id 0 sb-vm::edx-offset)))
    (coerce
     (mapcan
      #'(lambda (n)
	  (mapcar #'code-char (reverse (word->byte-list n))))
      (list ebx edx ecx))
     'string)))

(defun get-cpu-processor-brand ()
  (with-output-to-string (s)
    (dolist (n (mapcar #'(lambda (x)
			   (coerce x '(unsigned-byte 32)))
		       (list #x80000002 #x80000003 #x80000004)))
      (declare (type (unsigned-byte 32) n))
      (let ((eax (sb-c::%primitive %cpu-id n sb-vm::eax-offset))
	    (ebx (sb-c::%primitive %cpu-id n sb-vm::ebx-offset))
	    (ecx (sb-c::%primitive %cpu-id n sb-vm::ecx-offset))
	    (edx (sb-c::%primitive %cpu-id n sb-vm::edx-offset)))
	(dolist (word (list eax ebx ecx edx))
	  (dolist (code (reverse (word->byte-list word)))
	    (unless (zerop code)
	      (write-char (code-char code) s))))))))

%cpu-idは1つ目の引数にEAXの値、2つ目の引数に返してほしいレジスタのオフセットを指定するようにした。

レジスタの個数より多くののTN(レジスタ？)は作れないっぽい。 :temporaryで宣言したeaxなどをそのまま返り値に使いたかったけど、どうすればいいのかわからなかったので現在の形になった。

以下、実行結果

CL-USER> (get-cpu-vender)
"AuthenticAMD"
CL-USER>(get-cpu-processor-brand)
"AMD Athlon(tm) 64 X2 Dual Core Processor 3600+"