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 #!+darwin
  24 (define-alien-routine ("sysctlbyname" %sysctlbyname) int
  25   (name c-string)
  26   (oldp (* t))
  27   (oldlenp (* sb!unix:size-t))
  28   (newp (* t))
  29   (newlen sb!unix:size-t))
  30
  31 (defun sysctl (type &rest name)
  32   "Retrieves an integer or string value with the given name."
  33   (let ((name-len (length name)))
  34     (when (> name-len ctl-maxname)
  35       (error "sysctl name ~S is too long" name))
  36     (with-alien ((name-array (array int #.ctl-maxname))
  37                  (result-len sb!unix:size-t))
  38       (dotimes (off name-len)
  39         (setf (deref name-array off) (elt name off)))
  40       (ecase type
  41         (:int
  42          (with-alien ((result int))
  43            (setf result-len (alien-size int :bytes))
  44            (unless (minusp (%sysctl (cast name-array (* int)) name-len
  45                                     (addr result) (addr result-len) nil 0))
  46              result)))
  47         (:str
  48          (unless (minusp (%sysctl (cast name-array (* int)) name-len
  49                                   nil (addr result-len) nil 0))
  50            (with-alien ((result (* char) (make-alien char result-len)))
  51              (if (minusp (%sysctl (cast name-array (* int)) name-len
  52                                   result (addr result-len) nil 0))
  53                  (free-alien result)
  54                  (sb!unix::newcharstar-string result)))))))))
  55
  56 #!+darwin
  57 (defun sysctlbyname (type name)
  58   "Retrieves an integer or string value with the given name."
  59   (with-alien ((result-len sb!unix:size-t))
  60     (ecase type
  61       (:int
  62        (with-alien ((result int))
  63          (setf result-len (alien-size int :bytes))
  64          (unless (minusp (%sysctlbyname name (addr result)
  65                                         (addr result-len) nil 0))
  66            result)))
  67       (:str
  68        (unless (minusp (%sysctlbyname name nil (addr result-len) nil 0))
  69          (with-alien ((result (* char) (make-alien char result-len)))
  70            (if (minusp (%sysctlbyname name result (addr result-len) nil 0))
  71                (free-alien result)
  72                (sb!unix::newcharstar-string result))))))))
  73
  74 (defun software-type ()
  75   "Return a string describing the supporting software."
  76   #!-gnu-kfreebsd (sysctl :str ctl-kern kern-ostype)
  77   #!+gnu-kfreebsd "GNU/kFreeBSD")
  78
  79 (defun software-version ()
  80   "Return a string describing version of the supporting software, or NIL
  81    if not available."
  82   (or sb!sys::*software-version*
  83       (setf sb!sys::*software-version*
  84             (sysctl :str ctl-kern kern-osrelease))))
  85 \f
  86 ;;; Return system time, user time and number of page faults.
  87 (defun get-system-info ()
  88   (multiple-value-bind (err? utime stime maxrss ixrss idrss
  89                              isrss minflt majflt)
  90                        (sb!unix:unix-getrusage sb!unix:rusage_self)
  91     (declare (ignore maxrss ixrss idrss isrss minflt))
  92     (unless err?
  93       (simple-perror "Unix system call getrusage() failed" :errno utime))
  94
  95     (values utime stime majflt)))
  96
  97 ;;; support for CL:MACHINE-VERSION defined OAOO elsewhere
  98 (defun get-machine-version ()
  99   (or #!+darwin (sysctlbyname :str "machdep.cpu.brand_string")
 100       (sysctl :str ctl-hw hw-model)))