1 ;;;; OS interface functions for SBCL under BSD Unix.
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
9 ;;;; Check that target machine features are set up consistently with
12 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
13 (error "The :BSD feature is missing, we shouldn't be doing this code."))
15 (define-alien-routine ("sysctl" %sysctl
) int
17 (namelen unsigned-int
)
19 (oldlenp (* sb
!unix
:size-t
))
21 (newlen sb
!unix
:size-t
))
24 (define-alien-routine ("sysctlbyname" %sysctlbyname
) int
27 (oldlenp (* sb
!unix
:size-t
))
29 (newlen sb
!unix
:size-t
))
31 (defun sysctl (type &rest name
)
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
)))
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))
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))
55 (sb!unix
::newcharstar-string result
)))))))))
58 (defun sysctlbyname (type name
)
60 "Retrieves an integer or string value with the given name."
61 (with-alien ((result-len sb
!unix
:size-t
))
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))
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))
74 (sb!unix
::newcharstar-string result
))))))))
76 (defun software-type ()
78 "Return a string describing the supporting software."
79 #!-gnu-kfreebsd
(sysctl :str ctl-kern kern-ostype
)
80 #!+gnu-kfreebsd
"GNU/kFreeBSD")
82 (defun software-version ()
84 "Return a string describing version of the supporting software, or NIL
86 (or sb
!sys
::*software-version
*
87 (setf sb
!sys
::*software-version
*
88 (sysctl :str ctl-kern kern-osrelease
))))
90 ;;; Return system time, user time and number of page faults.
91 (defun get-system-info ()
92 (multiple-value-bind (err? utime stime maxrss ixrss idrss
94 (sb!unix
:unix-getrusage sb
!unix
:rusage_self
)
95 (declare (ignore maxrss ixrss idrss isrss minflt
))
97 (simple-perror "Unix system call getrusage() failed" :errno utime
))
99 (values utime stime majflt
)))
101 ;;; Return the system page size.
102 (defun get-page-size ()
103 (sysctl :int ctl-hw hw-pagesize
))
105 ;;; support for CL:MACHINE-VERSION defined OAOO elsewhere
106 (defun get-machine-version ()
107 (or #!+darwin
(sysctlbyname :str
"machdep.cpu.brand_string")
108 (sysctl :str ctl-hw hw-model
)))