[Git][cmucl/cmucl][issue-180-get-page-size-in-c] 8 commits: Fix #170: Move get-system-info to C
Raymond Toy (@rtoy)
gitlab at common-lisp.net
Wed Apr 19 16:52:54 UTC 2023
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/42a8fe564c94711f742837cdf4cce5bc5ab65862...0dc0b2280777c5dd10e1f25309a6587805edfdbc
--
View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/42a8fe564c94711f742837cdf4cce5bc5ab65862...0dc0b2280777c5dd10e1f25309a6587805edfdbc
You're receiving this email because of your account on gitlab.common-lisp.net.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://mailman.common-lisp.net/pipermail/cmucl-cvs/attachments/20230419/79f0775a/attachment-0001.html>
More information about the cmucl-cvs
mailing list