Raymond Toy pushed to branch issue-180-get-page-size-in-c at cmucl / cmucl
Commits: bbfff3c0 by Raymond Toy at 2023-04-10T15:11:59+00:00 Fix #170: Move get-system-info to C
- - - - - 5196072a by Raymond Toy at 2023-04-10T15:12:01+00:00 Merge branch 'issue-179-get-system-info-in-c' into 'master'
Fix #170: Move get-system-info to C
Closes #170
See merge request cmucl/cmucl!137 - - - - - b2aee0f7 by Raymond Toy at 2023-04-17T08:14:29-07:00 Update cmucl.pot with latest source
Some docstrings have changed, so update cmucl.pot
- - - - - fbb742ae by Raymond Toy at 2023-04-19T14:14:39+00:00 Fix #120: software-version in C
- - - - - 501ca837 by Raymond Toy at 2023-04-19T14:14:40+00:00 Merge branch 'issue-120-software-type-in-c' into 'master'
Fix #120: software-version in C
Closes #120, #130, #146, #136, #142, #134, and #132
See merge request cmucl/cmucl!93 - - - - - 2556df76 by Raymond Toy at 2023-04-19T07:38:34-07:00 Update pot files
Forgot to update these in the merges, so let's do them all now.
- - - - - dc1654d6 by Raymond Toy at 2023-04-19T08:32:04-07:00 Merge branch 'master' into issue-180-get-page-size-in-c
- - - - - 0dc0b228 by Raymond Toy at 2023-04-19T09:51:28-07:00 Add new file os.lisp to hold common OS functions independent of OS
Update the build files to compile this new file.
- - - - -
10 changed files:
- src/code/bsd-os.lisp - src/code/linux-os.lisp - src/code/misc.lisp - + src/code/os.lisp - src/code/sunos-os.lisp - src/code/unix.lisp - src/general-info/release-21e.md - src/lisp/os-common.c - src/tools/worldbuild.lisp - src/tools/worldcom.lisp
Changes:
===================================== src/code/bsd-os.lisp ===================================== @@ -48,19 +48,6 @@ #+Darwin "Darwin" #-(or freebsd NetBSD OpenBSD Darwin) "BSD")
-(defvar *software-version* nil "Version string for supporting software") - -(defun software-version () - "Returns a string describing version of the supporting software." - (unless *software-version* - (setf *software-version* - (string-trim '(#\newline) - (with-output-to-string (stream) - (run-program "/usr/bin/uname" - '("-r") - :output stream))))) - *software-version*) - ;;; OS-Init initializes our operating-system interface. It sets the values ;;; of the global port variables to what they should be and calls the functions @@ -83,5 +70,3 @@ (unix:get-unix-error-msg utime)))
(values utime stime majflt))) - -
===================================== src/code/linux-os.lisp ===================================== @@ -28,33 +28,20 @@
(setq *software-type* "Linux")
-;;; Instead of reading /proc/version (which has some bugs with -;;; select() in Linux kernel 2.6.x) and instead of running uname -r, -;;; let's just get the info from uname(). -(defun software-version () - "Returns a string describing version of the supporting software." - (multiple-value-bind (sysname nodename release version) - (unix:unix-uname) - (declare (ignore sysname nodename)) - (concatenate 'string release " " version))) - - ;;; OS-Init initializes our operating-system interface. ;;; -(defun os-init () nil) +(defun os-init () + (setf *software-version* nil)) +
+;;; GET-PAGE-SIZE -- Interface +;;; +;;; Return the system page size. +;;; +(defun get-page-size () + (multiple-value-bind (val err) + (unix:unix-getpagesize) + (unless val + (error (intl:gettext "Getpagesize failed: ~A") (unix:get-unix-error-msg err))) + val))
-;;; GET-SYSTEM-INFO -- Interface -;;; -;;; Return system time, user time and number of page faults. -;;; -(defun get-system-info () - (multiple-value-bind (err? utime stime maxrss ixrss idrss - isrss minflt majflt) - (unix:unix-getrusage unix:rusage_self) - (declare (ignore maxrss ixrss idrss isrss minflt)) - (unless err? - (error (intl:gettext "Unix system call getrusage failed: ~A.") - (unix:get-unix-error-msg utime))) - - (values utime stime majflt)))
===================================== src/code/misc.lisp ===================================== @@ -17,7 +17,7 @@ (in-package "LISP") (intl:textdomain "cmucl")
-(export '(documentation *features* variable room +(export '(*features* variable room lisp-implementation-type lisp-implementation-version machine-type machine-version machine-instance software-type software-version short-site-name long-site-name dribble compiler-macro)) @@ -81,12 +81,32 @@ (unix:unix-gethostname))
(defvar *software-type* "Unix" - "The value of SOFTWARE-TYPE. Set in FOO-os.lisp.") + _N"The value of SOFTWARE-TYPE. Set in FOO-os.lisp.")
(defun software-type () "Returns a string describing the supporting software." *software-type*)
+(defvar *software-version* nil + _N"Version string for supporting software") + +(defun software-version () + _N"Returns a string describing version of the supporting software." + (unless *software-version* + (setf *software-version* + (let (version result) + (unwind-protect + (progn + (setf version + (alien:alien-funcall + (alien:extern-alien "os_software_version" + (function (alien:* c-call:c-string))))) + (setf result (alien:cast version c-call:c-string)))) + (if (zerop (length result)) + "Unknown" + result))) + *software-version*)) + (defvar *short-site-name* nil "The value of SHORT-SITE-NAME. Set in library:site-init.lisp.")
===================================== src/code/os.lisp ===================================== @@ -0,0 +1,35 @@ +;;; -*- Package: SYSTEM -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; and has been placed in the public domain. +;;; +(ext:file-comment + "$Header: src/code/os.lisp $") +;;; +;;; ********************************************************************** +;;; +;;; OS interface functions for CMUCL. +;;; +;;; The code here is for OS functions that don't depend on the OS. + +(in-package "SYSTEM") +(use-package "EXTENSIONS") +(intl:textdomain "cmucl-linux-os") + +(export '(get-page-size)) + +;;; GET-PAGE-SIZE -- Interface +;;; +;;; Return the system page size. +;;; +(defun get-page-size () + _N"Return the system page size" + (let ((maybe-page-size (alien:alien-funcall + (alien:extern-alien "os_get_page_size" + (function c-call:long))))) + (when (minusp maybe-page-size) + (error (intl:gettext "get-page-size failed: ~A") (get-unix-error-msg err))) + maybe-page-size)) + +
===================================== src/code/sunos-os.lisp ===================================== @@ -33,19 +33,6 @@
(setq *software-type* "SunOS")
-(defvar *software-version* nil "Version string for supporting software") - -(defun software-version () - "Returns a string describing version of the supporting software." - (unless *software-version* - (setf *software-version* - (multiple-value-bind (sysname nodename release version) - (unix:unix-uname) - (declare (ignore sysname nodename)) - (concatenate 'string release " " version)))) - *software-version*) - - ;;; OS-INIT -- interface. ;;; ;;; Other OS dependent initializations.
===================================== src/code/unix.lisp ===================================== @@ -2922,14 +2922,27 @@ (function (* char)))) c-string))
-;;; GET-PAGE-SIZE -- Interface +;;; GET-SYSTEM-INFO -- Interface ;;; -;;; Return the system page size. +;;; Return system time, user time (in usec) and number of page +;;; faults. ;;; -(defun get-page-size () - (let ((maybe-page-size (alien-funcall - (extern-alien "os_get_page_size" - (function c-call:long))))) - (when (minusp maybe-page-size) - (error (intl:gettext "get-page-size failed: ~A") (get-unix-error-msg err))) - maybe-page-size)) +(defun get-system-info () + "Get system information consisting of the user time (in usec), the + system time (in usec) and the number of major page faults." + (with-alien ((utime int64-t 0) + (stime int64-t 0) + (major-fault c-call:long 0)) + (let ((rc (alien-funcall + (extern-alien "os_get_system_info" + (function c-call:int + (* int64-t) + (* int64-t) + (* c-call:long))) + (addr utime) + (addr stime) + (addr major-fault)))) + (when (minusp rc) + (error (intl:gettext "Unix system call getrusage failed: ~A.") + (unix:get-unix-error-msg utime))) + (values utime stime major-fault))))
===================================== src/general-info/release-21e.md ===================================== @@ -49,10 +49,11 @@ public domain. * ~~#108~~ Update ASDF. * ~~#112~~ CLX can't connect to X server via inet sockets. * ~~#113~~ REQUIRE on contribs can pull in the wrong things via ASDF. - * ~~#121~~ Wrong column index in FILL-POINTER-OUTPUT-STREAM. - * ~~#122~~ gcc 11 can't build cmucl. - * ~~#124~~ directory with `:wild-inferiors` doesn't descend subdirectories. - * ~~#125~~ Linux `unix-stat` returning incorrect values. + * ~~#120~~ `SOFTWARE-VERSION` is implemented in C. + * ~~#121~~ Wrong column index in FILL-POINTER-OUTPUT-STREAM + * ~~#122~~ gcc 11 can't build cmucl + * ~~#124~~ directory with `:wild-inferiors` doesn't descend subdirectories + * ~~#125~~ Linux `unix-stat` returning incorrect values * ~~#127~~ Linux unix-getpwuid segfaults when given non-existent uid. * ~~#128~~ `QUIT` accepts an exit code. * ~~#130~~ Move file-author to C.
===================================== src/lisp/os-common.c ===================================== @@ -15,7 +15,9 @@ #include <stdio.h> #include <stdlib.h> #include <string.h> +#include <sys/resource.h> #include <sys/stat.h> +#include <sys/utsname.h> #include <unistd.h> #include <time.h>
@@ -811,3 +813,53 @@ os_get_page_size(void)
return sysconf(_SC_PAGESIZE); } + +/* + * Get system info consisting of the utime (in usec), the stime (in + * usec) and the number of major page faults. The return value is the + * return code from getrusage. + */ +int +os_get_system_info(int64_t* utime, int64_t* stime, long* major_fault) +{ + struct rusage usage; + int rc; + + *utime = 0; + *stime = 0; + *major_fault = 0; + + rc = getrusage(RUSAGE_SELF, &usage); + if (rc == 0) { + *utime = usage.ru_utime.tv_sec * 1000000 + usage.ru_utime.tv_usec; + *stime = usage.ru_stime.tv_sec * 1000000 + usage.ru_stime.tv_usec; + *major_fault = usage.ru_majflt; + } + + return rc; +} + +/* + * Get the software version. This is the same as "uname -r", the release. + * A pointer to a static string is returned. If uname fails, an empty + * string is returned. + */ +char* +os_software_version(void) +{ + struct utsname uts; + int status; + + /* + * Buffer large enough to hold the release. + */ + static char result[sizeof(uts.release)]; + result[0] = '\0'; + + status = uname(&uts); + if (status == 0) { + strcpy(result, uts.release); + } + + return result; +}
===================================== src/tools/worldbuild.lisp ===================================== @@ -147,6 +147,7 @@ '("target:code/bsd-os")) ,@(when (c:backend-featurep :Linux) '("target:code/linux-os")) + "target:code/os" "target:code/serve-event" "target:code/stream" "target:code/fd-stream"
===================================== src/tools/worldcom.lisp ===================================== @@ -173,6 +173,7 @@ (comf "target:code/bsd-os")) (when (c:backend-featurep :Linux) (comf "target:code/linux-os")) +(comf "target:code/os")
(when (c:backend-featurep :pmax) (comf "target:code/pmax-vm"))
View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/42a8fe564c94711f742837c...