From d0552bdb80b50eb2c600de19b89b2d7139c4841c Mon Sep 17 00:00:00 2001 From: William Harold Newman Date: Thu, 26 Jun 2003 18:58:44 +0000 Subject: [PATCH] 0.8.1.7: improved GET-MACHINE-VERSION implementation in some #+LINUX cases (thanks to Lars Brinkhoff) OAOOish tidying of CL:MACHINE-VERSION --- NEWS | 4 +++- package-data-list.lisp-expr | 4 ++-- src/code/alpha-vm.lisp | 7 ++++--- src/code/hppa-vm.lisp | 7 +++---- src/code/mips-vm.lisp | 5 ++--- src/code/ppc-vm.lisp | 28 +++++++++++++++++++++++----- src/code/sparc-vm.lisp | 11 +++-------- src/code/target-misc.lisp | 10 ++++++++++ src/code/x86-vm.lisp | 23 +++++++++++++++++++---- version.lisp-expr | 2 +- 10 files changed, 70 insertions(+), 31 deletions(-) diff --git a/NEWS b/NEWS index b479b76..d42783f 100644 --- a/NEWS +++ b/NEWS @@ -1879,7 +1879,7 @@ changes in sbcl-0.8.1 relative to sbcl-0.8.0: treated by SLOT-BOUNDP, SLOT-VALUE, (SETF SLOT-VALUE) and SLOT-MAKUNBOUND in the specified fashion. -changes in sbcl-0.8.1 relative to sbcl-0.8.0: +changes in sbcl-0.8.2 relative to sbcl-0.8.1: * fixed bug 148: failure to inline-expand a local function left garbage, confusing the compiler. * fixed bugs 3cd: structure slot readers perform type check if the @@ -1888,6 +1888,8 @@ changes in sbcl-0.8.1 relative to sbcl-0.8.0: * bug fix: the compiler now traps array references to elements off the end of an array; previously, the bounds checking in some circumstances could go off-by-one. + * improved MACHINE-VERSION, especially on Linux (thanks to Lars + Brinkhoff) planned incompatible changes in 0.8.x: * (not done yet, but planned:) When the profiling interface settles diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index b2cc21a..6bc5a2b 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1092,8 +1092,8 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "GENERALIZED-BOOLEAN" "GET-CLOSURE-LENGTH" "GET-HEADER-DATA" - "GET-LISP-OBJ-ADDRESS" "LOWTAG-OF" - "WIDETAG-OF" + "GET-LISP-OBJ-ADDRESS" "LOWTAG-OF" "WIDETAG-OF" + "GET-MACHINE-VERSION" "HAIRY-DATA-VECTOR-REF" "HAIRY-DATA-VECTOR-SET" "HAIRY-TYPE" "HAIRY-TYPE-CHECK-TEMPLATE-NAME" "HAIRY-TYPE-SPECIFIER" "HANDLE-CIRCULARITY" "HOST" "IGNORE-IT" diff --git a/src/code/alpha-vm.lisp b/src/code/alpha-vm.lisp index 343e746..ffddc72 100644 --- a/src/code/alpha-vm.lisp +++ b/src/code/alpha-vm.lisp @@ -22,9 +22,10 @@ (defun machine-type () "Return a string describing the type of the local machine." "Alpha") -(defun machine-version () - "Return a string describing the version of the local machine." - "Alpha") + +;;; support for CL:MACHINE-VERSION defined OAOO elsewhere +(defun get-machine-version () + nil) (defun fixup-code-object (code offset value kind) (unless (zerop (rem offset n-word-bytes)) diff --git a/src/code/hppa-vm.lisp b/src/code/hppa-vm.lisp index ebc0051..23a161f 100644 --- a/src/code/hppa-vm.lisp +++ b/src/code/hppa-vm.lisp @@ -8,10 +8,9 @@ "Returns a string describing the type of the local machine." "HPPA") -(defun machine-version () - "Returns a string describing the version of the local machine." - "HPPA") - +;;; support for CL:MACHINE-VERSION defined OAOO elsewhere +(defun get-machine-version () + nil) ;;;; FIXUP-CODE-OBJECT diff --git a/src/code/mips-vm.lisp b/src/code/mips-vm.lisp index 558d293..264e871 100644 --- a/src/code/mips-vm.lisp +++ b/src/code/mips-vm.lisp @@ -8,11 +8,10 @@ "Returns a string describing the type of the local machine." "MIPS") -(defun machine-version () - "Returns a string describing the version of the local machine." +;;; support for CL:MACHINE-VERSION defined OAOO elsewhere +(defun get-machine-version () #!+little-endian "little-endian" #!-little-endian "big-endian") - ;;;; FIXUP-CODE-OBJECT diff --git a/src/code/ppc-vm.lisp b/src/code/ppc-vm.lisp index 801192d..a9297a6 100644 --- a/src/code/ppc-vm.lisp +++ b/src/code/ppc-vm.lisp @@ -14,11 +14,29 @@ "Returns a string describing the type of the local machine." "PowerPC") -(defun machine-version () - "Returns a string describing the version of the local machine." - "who-knows?") - - +;;; support for CL:MACHINE-VERSION defined OAOO elsewhere +(defun get-machine-version () + #!+linux + (with-open-file (stream "/proc/cpuinfo" + ;; /proc is optional even in Linux, so + ;; fail gracefully. + :if-does-not-exist nil) + (loop with line while (setf line (read-line stream nil)) + ;; hoping "cpu" exists and gives something useful in + ;; all relevant Linuxen... + ;; + ;; from Lars Brinkhoff sbcl-devel 26 Jun 2003: + ;; I examined different versions of Linux/PPC at + ;; http://lxr.linux.no/ (the file that outputs + ;; /proc/cpuinfo is arch/ppc/kernel/setup.c, if + ;; you want to check), and all except 2.0.x + ;; seemed to do the same thing as far as the + ;; "cpu" field is concerned, i.e. it always + ;; starts with the (C-syntax) string "cpu\t\t: ". + when (eql (search "cpu" line) 0) + return (string-trim " " (subseq line (1+ (position #\: line)))))) + #!-linux + nil) ;;;; FIXUP-CODE-OBJECT diff --git a/src/code/sparc-vm.lisp b/src/code/sparc-vm.lisp index 3d214b5..6c3d95e 100644 --- a/src/code/sparc-vm.lisp +++ b/src/code/sparc-vm.lisp @@ -9,13 +9,9 @@ ;;;; provided with absolutely no warranty. See the COPYING and CREDITS ;;;; files for more information. (in-package "SB!VM") - - ;;; See x86-vm.lisp for a description of this. (define-alien-type os-context-t (struct os-context-t-struct)) - - ;;;; MACHINE-TYPE and MACHINE-VERSION @@ -23,10 +19,9 @@ "Returns a string describing the type of the local machine." "SPARC") -(defun machine-version () - "Returns a string describing the version of the local machine." - "SPARC") - +;;; support for CL:MACHINE-VERSION defined OAOO elsewhere +(defun get-machine-version () + nil) (defun fixup-code-object (code offset fixup kind) (declare (type index offset)) diff --git a/src/code/target-misc.lisp b/src/code/target-misc.lisp index a9af065..37bb400 100644 --- a/src/code/target-misc.lisp +++ b/src/code/target-misc.lisp @@ -123,6 +123,16 @@ "Return a string giving the name of the local machine." (sb!unix:unix-gethostname)) +(defvar *machine-version*) + +(defun machine-version () + #!+sb-doc + "Return a string describing the version of the computer hardware we +are running on, or NIL if we can't find any useful information." + (unless (boundp '*machine-version*) + (setf *machine-version* (get-machine-version))) + *machine-version*) + ;;; FIXME: Don't forget to set these in a sample site-init file. ;;; FIXME: Perhaps the functions could be SETFable instead of having the ;;; interface be through special variables? As far as I can tell diff --git a/src/code/x86-vm.lisp b/src/code/x86-vm.lisp index 203b2bb..bd1935f 100644 --- a/src/code/x86-vm.lisp +++ b/src/code/x86-vm.lisp @@ -41,10 +41,25 @@ "Return a string describing the type of the local machine." "X86") -(defun machine-version () - #!+sb-doc - "Return a string describing the version of the local machine." - "X86") +;;; arch-specific support for CL:MACHINE-VERSION, defined OAOO elsewhere +(defun get-machine-version () + #!+linux + (with-open-file (stream "/proc/cpuinfo" + ;; Even on Linux it's an option to build + ;; kernels without /proc filesystems, so + ;; degrade gracefully. + :if-does-not-exist nil) + (loop with line while (setf line (read-line stream nil)) + ;; The field "model name" exists on kernel 2.4.21-rc6-ac1 + ;; anyway, with values e.g. + ;; "AMD Athlon(TM) XP 2000+" + ;; "Intel(R) Pentium(R) M processor 1300MHz" + ;; which seem comparable to the information in the example + ;; in the MACHINE-VERSION page of the ANSI spec. + when (eql (search "model name" line) 0) + return (string-trim " " (subseq line (1+ (position #\: line)))))) + #!-linux + nil) ;;;; :CODE-OBJECT fixups diff --git a/version.lisp-expr b/version.lisp-expr index 455ce52..65691ce 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.8.1.6" +"0.8.1.7" -- 1.7.10.4