1.0.28.44: better MACHINE-VERSION answers on BSD'ish platforms
[sbcl.git] / src / code / bsd-os.lisp
1 ;;;; OS interface functions for SBCL under BSD Unix.
2
3 ;;;; This code was written as part of the CMU Common Lisp project at
4 ;;;; Carnegie Mellon University, and has been placed in the public
5 ;;;; domain.
6
7 (in-package "SB!IMPL")
8
9 ;;;; Check that target machine features are set up consistently with
10 ;;;; this file.
11 #!-bsd
12 (eval-when (:compile-toplevel :load-toplevel :execute)
13   (error "The :BSD feature is missing, we shouldn't be doing this code."))
14
15 (define-alien-routine ("sysctl" %sysctl) int
16   (name (* int))
17   (namelen unsigned-int)
18   (oldp (* t))
19   (oldlenp (* sb!unix:size-t))
20   (newp (* t))
21   (newlen sb!unix:size-t))
22
23 (defun sysctl (type &rest name)
24   #!+sb-doc
25   "Retrieves an integer or string value with the given name."
26   (let ((name-len (length name)))
27     (when (> name-len ctl-maxname)
28       (error "sysctl name ~S is too long" name))
29     (with-alien ((name-array (array int #.ctl-maxname))
30                  (result-len sb!unix:size-t))
31       (dotimes (off name-len)
32         (setf (deref name-array off) (elt name off)))
33       (ecase type
34         (:int
35          (with-alien ((result int))
36            (setf result-len (alien-size int :bytes))
37            (unless (minusp (%sysctl (cast name-array (* int)) name-len
38                                     (addr result) (addr result-len) nil 0))
39              result)))
40         (:str
41          (unless (minusp (%sysctl (cast name-array (* int)) name-len
42                                   nil (addr result-len) nil 0))
43            (with-alien ((result (* char) (make-alien char result-len)))
44              (if (minusp (%sysctl (cast name-array (* int)) name-len
45                                   result (addr result-len) nil 0))
46                  (free-alien result)
47                  (sb!unix::newcharstar-string result)))))))))
48
49 (defun software-type ()
50   #!+sb-doc
51   "Return a string describing the supporting software."
52   (sysctl :str ctl-kern kern-ostype))
53
54 (defun software-version ()
55   #!+sb-doc
56   "Return a string describing version of the supporting software, or NIL
57    if not available."
58   (or sb!sys::*software-version*
59       (setf sb!sys::*software-version*
60             (sysctl :str ctl-kern kern-osrelease))))
61 \f
62 ;;; Return system time, user time and number of page faults.
63 (defun get-system-info ()
64   (multiple-value-bind (err? utime stime maxrss ixrss idrss
65                              isrss minflt majflt)
66                        (sb!unix:unix-getrusage sb!unix:rusage_self)
67     (declare (ignore maxrss ixrss idrss isrss minflt))
68     (unless err?
69       (simple-perror "Unix system call getrusage() failed" :errno utime))
70
71     (values utime stime majflt)))
72
73 ;;; Return the system page size.
74 (defun get-page-size ()
75   (sysctl :int ctl-hw hw-pagesize))
76
77 ;;; support for CL:MACHINE-VERSION defined OAOO elsewhere
78 (defun get-machine-version ()
79   ;; FIXME: on Darwin we would prefer machdep.cpu.brand_string -- but I can't
80   ;; seem to grab it using sysctl() -- but the shell tool finds it. When
81   ;; someone has the time, check out how Darwin shell sysctl does it.
82   (sysctl :str ctl-hw hw-model))