[Git][cmucl/cmucl][master] 2 commits: Fix #71: More info from machine-type/version on x86

[Raymond Toy]

Raymond Toy pushed to branch master at cmucl / cmucl


Commits:
0824e61e by Raymond Toy at 2018-12-06T22:42:16Z
Fix #71: More info from machine-type/version on x86

- - - - -
3843a50c by Raymond Toy at 2018-12-06T22:42:16Z
Merge branch 'rtoy-issue-71' into 'master'

Fix #71: More info from machine-type/version on x86

Closes #71

See merge request cmucl/cmucl!42
- - - - -


2 changed files:

- src/code/x86-vm.lisp
- src/general-info/release-21d.md


Changes:

=====================================
src/code/x86-vm.lisp
=====================================
@@ -60,14 +60,56 @@
 #-cross-compiler
 (defun machine-type ()
   _N"Returns a string describing the type of the local machine."
-  "X86")
+  ;; Use cpuid to get the processor type.
+  (with-output-to-string (s)
+    (multiple-value-bind (max-input ebx ecx edx)
+	(x86::cpuid 0)
+      (declare (ignore max-input))
+      (flet ((int-to-string (int)
+	       (dotimes (k 4)
+		 (let ((code (ldb (byte 8 (* 8 k)) int)))
+		   ;; Don't print out null chars.  We're
+		   ;; assuming this only happens at the end
+		   ;; of the brand string.
+		   (unless (zerop code)
+		     (write-char (code-char code) s))))))
+	(int-to-string ebx)
+	(int-to-string edx)
+	(int-to-string ecx)))))
 
 
 #-cross-compiler
 (defun machine-version ()
   _N"Returns a string describing the version of the local machine."
-  "X86")
-
+  ;; UWe use the processor brand string method to get more detailed
+  ;; information about the processor.  If it's not available, just
+  ;; give up, even though we could use the brand index (CPUID with
+  ;; EAX=1) to get an identifier.
+  (let ((max-cpuid (x86::cpuid #x80000000)))
+    (cond ((or (not (logbitp 31 max-cpuid))
+	       (< max-cpuid #x80000004))
+	   ;; Processor brand string not supported, just give up.
+	   "X86")
+	  (t
+	   (with-output-to-string (s)
+	     (labels ((int-to-string (int)
+			(dotimes (k 4)
+			  (let ((code (ldb (byte 8 (* 8 k)) int)))
+			    ;; Don't print out null chars.  We're
+			    ;; assuming this only happens at the end
+			    ;; of the brand string.
+			    (unless (zerop code)
+			      (write-char (code-char code) s)))))
+		      (cpuid-to-string (input)
+			(multiple-value-bind (eax ebx ecx edx)
+			    (x86::cpuid input)
+			  (int-to-string eax)
+			  (int-to-string ebx)
+			  (int-to-string ecx)
+			  (int-to-string edx))))
+	       (cpuid-to-string #x80000002)
+	       (cpuid-to-string #x80000003)
+	       (cpuid-to-string #x80000004)))))))
 
 
 ;;; Fixup-Code-Object -- Interface


=====================================
src/general-info/release-21d.md
=====================================
@@ -27,6 +27,7 @@ public domain.
       * The new function `KERNEL:RANDOM-STATE-JUMP` modifies the given state to jump 2^64 samples ahead, allowing 2^64 non-overlapping sequences.
     * Updated CLX to telent clx version 06e39a0d.
     * New functions `SET-GC-ASSERTIONS` and `GET-GC-ASSERTIONS`.  See the docstrings for more information and also ~~#69~~.
+    * `MACHINE-TYPE` and `MACHINE-VERSION` return more information about thep rocessor cmucl is running on, using information from the `cpuid` instruction.
   * ANSI compliance fixes:
   * Bug fixes:
   * Gitlab tickets:



View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/b6faace8b52fa8ca8ce5c3ed30fbef9a9b8f4af2...3843a50c6aea367e8a16ff217eb99ee6ba87dd25

-- 
View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/b6faace8b52fa8ca8ce5c3ed30fbef9a9b8f4af2...3843a50c6aea367e8a16ff217eb99ee6ba87dd25
You're receiving this email because of your account on gitlab.common-lisp.net.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://mailman.common-lisp.net/pipermail/cmucl-cvs/attachments/20181206/4e3b99f1/attachment-0001.html>