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