From: Nikodemus Siivola Date: Wed, 13 May 2009 13:58:31 +0000 (+0000) Subject: 1.0.28.44: better MACHINE-VERSION answers on BSD'ish platforms X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=2b0851c405b494143009f68e2bc7e91017a809d4;p=sbcl.git 1.0.28.44: better MACHINE-VERSION answers on BSD'ish platforms Also reduce OAOOMity of GET-MACHINE-VERSION. Patch by Josh Elsasser. --- diff --git a/NEWS b/NEWS index 3a93e5a..8760976 100644 --- a/NEWS +++ b/NEWS @@ -20,6 +20,7 @@ open coding of ARRAY-RANK. * improvement: SBCL now emits a compiler note where stack allocation was requested but could not be provided. + * improvement: better MACHINE-VERSION responses. (thanks to Josh Elsasser) * improvement: pretty-printing loop has been implemented properly. (thanks to Tobias Rittweiler) * documentation: CLOS slot typechecing policy has been documented. diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 723d822..0ca3618 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1410,7 +1410,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "FUN-WORD-OFFSET" "GENERALIZED-BOOLEAN" "GET-CLOSURE-LENGTH" "GET-HEADER-DATA" "GET-LISP-OBJ-ADDRESS" "LOWTAG-OF" "WIDETAG-OF" - "GET-MACHINE-VERSION" "HAIRY-DATA-VECTOR-REF" + "HAIRY-DATA-VECTOR-REF" "HAIRY-DATA-VECTOR-REF/CHECK-BOUNDS" "HAIRY-DATA-VECTOR-SET" "HAIRY-DATA-VECTOR-SET/CHECK-BOUNDS""HAIRY-TYPE" "HAIRY-TYPE-CHECK-TEMPLATE-NAME" "HAIRY-TYPE-SPECIFIER" @@ -2194,7 +2194,7 @@ SB-KERNEL) have been undone, but probably more remain." "FOREIGN-SYMBOL-SAP" "FOREIGN-SYMBOL-ADDRESS" "FOREIGN-SYMBOL-DATAREF-SAP" - "GET-PAGE-SIZE" "GET-SYSTEM-INFO" + "GET-MACHINE-VERSION" "GET-PAGE-SIZE" "GET-SYSTEM-INFO" "IGNORE-INTERRUPT" "IN-INTERRUPTION" "INTERACTIVE-INTERRUPT" diff --git a/src/code/alpha-vm.lisp b/src/code/alpha-vm.lisp index 71f99b5..e8b4875 100644 --- a/src/code/alpha-vm.lisp +++ b/src/code/alpha-vm.lisp @@ -14,15 +14,11 @@ ;;; 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 +;;;; MACHINE-TYPE (defun machine-type () "Return a string describing the type 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/bsd-os.lisp b/src/code/bsd-os.lisp index 97814f2..dca2b6f 100644 --- a/src/code/bsd-os.lisp +++ b/src/code/bsd-os.lisp @@ -4,7 +4,7 @@ ;;;; Carnegie Mellon University, and has been placed in the public ;;;; domain. -(in-package "SB!SYS") +(in-package "SB!IMPL") ;;;; Check that target machine features are set up consistently with ;;;; this file. @@ -12,25 +12,52 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (error "The :BSD feature is missing, we shouldn't be doing this code.")) +(define-alien-routine ("sysctl" %sysctl) int + (name (* int)) + (namelen unsigned-int) + (oldp (* t)) + (oldlenp (* sb!unix:size-t)) + (newp (* t)) + (newlen sb!unix:size-t)) + +(defun sysctl (type &rest name) + #!+sb-doc + "Retrieves an integer or string value with the given name." + (let ((name-len (length name))) + (when (> name-len ctl-maxname) + (error "sysctl name ~S is too long" name)) + (with-alien ((name-array (array int #.ctl-maxname)) + (result-len sb!unix:size-t)) + (dotimes (off name-len) + (setf (deref name-array off) (elt name off))) + (ecase type + (:int + (with-alien ((result int)) + (setf result-len (alien-size int :bytes)) + (unless (minusp (%sysctl (cast name-array (* int)) name-len + (addr result) (addr result-len) nil 0)) + result))) + (:str + (unless (minusp (%sysctl (cast name-array (* int)) name-len + nil (addr result-len) nil 0)) + (with-alien ((result (* char) (make-alien char result-len))) + (if (minusp (%sysctl (cast name-array (* int)) name-len + result (addr result-len) nil 0)) + (free-alien result) + (sb!unix::newcharstar-string result))))))))) + (defun software-type () #!+sb-doc "Return a string describing the supporting software." - (the string ; (to force error in case of unsupported BSD variant) - #!+FreeBSD "FreeBSD" - #!+OpenBSD "OpenBSD" - #!+NetBSD "NetBSD" - #!+Darwin "Darwin")) + (sysctl :str ctl-kern kern-ostype)) (defun software-version () #!+sb-doc "Return a string describing version of the supporting software, or NIL if not available." - (or *software-version* - (setf *software-version* - (string-trim '(#\newline) - (with-output-to-string (stream) - (sb!ext:run-program "/usr/bin/uname" `("-r") - :output stream)))))) + (or sb!sys::*software-version* + (setf sb!sys::*software-version* + (sysctl :str ctl-kern kern-osrelease)))) ;;; Return system time, user time and number of page faults. (defun get-system-info () @@ -45,5 +72,11 @@ ;;; Return the system page size. (defun get-page-size () - ;; FIXME: probably should call getpagesize() - 4096) + (sysctl :int ctl-hw hw-pagesize)) + +;;; support for CL:MACHINE-VERSION defined OAOO elsewhere +(defun get-machine-version () + ;; FIXME: on Darwin we would prefer machdep.cpu.brand_string -- but I can't + ;; seem to grab it using sysctl() -- but the shell tool finds it. When + ;; someone has the time, check out how Darwin shell sysctl does it. + (sysctl :str ctl-hw hw-model)) diff --git a/src/code/hppa-vm.lisp b/src/code/hppa-vm.lisp index 5573841..70f0bbc 100644 --- a/src/code/hppa-vm.lisp +++ b/src/code/hppa-vm.lisp @@ -2,15 +2,11 @@ (define-alien-type os-context-t (struct os-context-t-struct)) -;;;; MACHINE-TYPE and MACHINE-VERSION +;;;; MACHINE-TYPE (defun machine-type () "Returns a string describing the type of the local machine." "HPPA") - -;;; support for CL:MACHINE-VERSION defined OAOO elsewhere -(defun get-machine-version () - nil) ;;;; FIXUP-CODE-OBJECT ;FIX-lav: unify code with genesis.lisp fixup diff --git a/src/code/hpux-os.lisp b/src/code/hpux-os.lisp index ed904e8..bf36b57 100644 --- a/src/code/hpux-os.lisp +++ b/src/code/hpux-os.lisp @@ -41,3 +41,6 @@ (error "Unix system call getrusage failed: ~A." (strerror utime))) (values utime stime majflt))) +;;; support for CL:MACHINE-VERSION defined OAOO elsewhere +(defun get-machine-version () + nil) diff --git a/src/code/linux-os.lisp b/src/code/linux-os.lisp index 134ca54..2efe31b 100644 --- a/src/code/linux-os.lisp +++ b/src/code/linux-os.lisp @@ -46,3 +46,40 @@ ;;; Return the system page size. (defun get-page-size () sb!c:*backend-page-bytes*) + +;;; support for CL:MACHINE-VERSION defined OAOO elsewhere +(defun get-machine-version () + (or + #!+(and mips little-endian) + "little-endian" + #!+(and mips big-endian) + "big-endian" + (let ((marker + ;; 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: ". + #!+ppc "cpu" + ;; 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. + #!+(or x86 x86-64) "model name")) + (when marker + (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)) + when (eql (search marker line) 0) + return (string-trim " " (subseq line (1+ (position #\: line)))))))))) diff --git a/src/code/mips-vm.lisp b/src/code/mips-vm.lisp index 4b077a0..df647eb 100644 --- a/src/code/mips-vm.lisp +++ b/src/code/mips-vm.lisp @@ -7,17 +7,11 @@ (define-alien-type os-context-register-t unsigned-long-long) -;;;; MACHINE-TYPE and MACHINE-VERSION +;;;; MACHINE-TYPE (defun machine-type () "Returns a string describing the type of the local machine." "MIPS") - -;;; 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/osf1-os.lisp b/src/code/osf1-os.lisp index 59f6311..2171c8e 100644 --- a/src/code/osf1-os.lisp +++ b/src/code/osf1-os.lisp @@ -47,3 +47,7 @@ ;; FIXME: Or we could just get rid of this, since the uses of it look ;; disposable. 4096) + +;;; support for CL:MACHINE-VERSION defined OAOO elsewhere +(defun get-machine-version () + nil) diff --git a/src/code/ppc-vm.lisp b/src/code/ppc-vm.lisp index 1a876d6..c3fdc16 100644 --- a/src/code/ppc-vm.lisp +++ b/src/code/ppc-vm.lisp @@ -5,35 +5,11 @@ (define-alien-type os-context-t (struct os-context-t-struct)) -;;;; MACHINE-TYPE and MACHINE-VERSION +;;;; MACHINE-TYPE (defun machine-type () "Returns a string describing the type of the local machine." "PowerPC") - -;;; 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 129c835..22930ed 100644 --- a/src/code/sparc-vm.lisp +++ b/src/code/sparc-vm.lisp @@ -13,15 +13,11 @@ ;;; 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 +;;;; MACHINE-TYPE (defun machine-type () "Returns a string describing the type 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/sunos-os.lisp b/src/code/sunos-os.lisp index 07a53f2..ae4b233 100644 --- a/src/code/sunos-os.lisp +++ b/src/code/sunos-os.lisp @@ -49,3 +49,7 @@ ;; FIXME II: this could well be wrong #!+sparc 8192 #!+(or x86 x86-64) 4096) + +;;; support for CL:MACHINE-VERSION defined OAOO elsewhere +(defun get-machine-version () + nil) diff --git a/src/code/win32-os.lisp b/src/code/win32-os.lisp index fa82edb..b548905 100644 --- a/src/code/win32-os.lisp +++ b/src/code/win32-os.lisp @@ -46,3 +46,7 @@ ;; FIXME: Or we could just get rid of this, since the uses of it look ;; disposable. 4096) + +;;; support for CL:MACHINE-VERSION defined OAOO elsewhere +(defun get-machine-version () + nil) diff --git a/src/code/x86-64-vm.lisp b/src/code/x86-64-vm.lisp index e263853..337e787 100644 --- a/src/code/x86-64-vm.lisp +++ b/src/code/x86-64-vm.lisp @@ -34,32 +34,12 @@ ;;; some other package, perhaps SB-KERNEL. (define-alien-type os-context-t (struct os-context-t-struct)) -;;;; MACHINE-TYPE and MACHINE-VERSION +;;;; MACHINE-TYPE (defun machine-type () #!+sb-doc "Return a string describing the type of the local machine." "X86-64") - -;;; 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/src/code/x86-vm.lisp b/src/code/x86-vm.lisp index bb1bd22..c9897ab 100644 --- a/src/code/x86-vm.lisp +++ b/src/code/x86-vm.lisp @@ -34,32 +34,12 @@ ;;; some other package, perhaps SB-KERNEL. (define-alien-type os-context-t (struct os-context-t-struct)) -;;;; MACHINE-TYPE and MACHINE-VERSION +;;;; MACHINE-TYPE (defun machine-type () #!+sb-doc "Return a string describing the type 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/tools-for-build/grovel-headers.c b/tools-for-build/grovel-headers.c index a529fcb..58458b0 100644 --- a/tools-for-build/grovel-headers.c +++ b/tools-for-build/grovel-headers.c @@ -51,6 +51,11 @@ #include /* for TIOCGPGRP */ #endif +#ifdef LISP_FEATURE_BSD + #include + #include +#endif + #include "wrap.h" #define DEFTYPE(lispname,cname) { cname foo; \ @@ -432,5 +437,18 @@ main(int argc, char *argv[]) defconstant("fpe-fltsub", -1); #endif #endif // !WIN32 + +#ifdef LISP_FEATURE_BSD + printf(";;; sysctl(3) names\n"); + printf("(in-package \"SB!IMPL\")\n\n"); + defconstant("ctl-kern", CTL_KERN); + defconstant("ctl-hw", CTL_HW); + defconstant("ctl-maxname", CTL_MAXNAME); + defconstant("kern-ostype", KERN_OSTYPE); + defconstant("kern-osrelease", KERN_OSRELEASE); + defconstant("hw-model", HW_MODEL); + defconstant("hw-pagesize", HW_PAGESIZE); + printf("\n"); +#endif return 0; } diff --git a/tools-for-build/ldso-stubs.lisp b/tools-for-build/ldso-stubs.lisp index 09b4574..8fa13b0 100644 --- a/tools-for-build/ldso-stubs.lisp +++ b/tools-for-build/ldso-stubs.lisp @@ -326,6 +326,8 @@ ldso_stub__ ## fct: ; \\ "dlerror" "dlopen" "dlsym") + #!+bsd + '("sysctl") #!+os-provides-dladdr '("dladdr") #!-sunos ;; !defined(SVR4) diff --git a/version.lisp-expr b/version.lisp-expr index f181b56..4592744 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".) -"1.0.28.43" +"1.0.28.44"