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))