[Git][cmucl/cmucl][issue-180-get-page-size-in-c] 8 commits: Fix #170: Move get-system-info to C - cmucl-cvs - mailman3.common-lisp.net

19 Apr 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 &#39;issue-179-get-system-info-in-c&#39; into &#39;master&#39;
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 &#39;issue-120-software-type-in-c&#39; into &#39;master&#39;
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&#39;s do them all now.
- - - - -
dc1654d6 by Raymond Toy at 2023-04-19T08:32:04-07:00
Merge branch &#39;master&#39; 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...
-- 
View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/42a8fe564c94711f742837c...
You're receiving this email because of your account on gitlab.common-lisp.net.





    