Raymond Toy pushed to branch issue-180-get-page-size-in-c at cmucl / cmucl

Commits:

10 changed files:

Changes:

  • src/code/bsd-os.lisp
    ... ... @@ -48,19 +48,6 @@
    48 48 
     		      #+Darwin "Darwin"
    49 49 
     		      #-(or freebsd NetBSD OpenBSD Darwin) "BSD")
    50 50
    51 
    -(defvar *software-version* nil "Version string for supporting software")
    52 
    -
    53 
    -(defun software-version ()
    54 
    -  "Returns a string describing version of the supporting software."
    55 
    -  (unless *software-version*
    56 
    -    (setf *software-version*
    57 
    -	  (string-trim '(#\newline)
    58 
    -		       (with-output-to-string (stream)
    59 
    -			 (run-program "/usr/bin/uname"
    60 
    -				      '("-r")
    61 
    -				      :output stream)))))
    62 
    -  *software-version*)
    63 
    -
    64 51
    65 52 
     ;;; OS-Init initializes our operating-system interface.  It sets the values
    66 53 
     ;;; of the global port variables to what they should be and calls the functions
    ... ... @@ -83,5 +70,3 @@
    83 70 
     	     (unix:get-unix-error-msg utime)))
    84 71
    85 72 
         (values utime stime majflt)))
    86 
    -
    87 
    -

  • src/code/linux-os.lisp
    ... ... @@ -28,33 +28,20 @@
    28 28
    29 29 
     (setq *software-type* "Linux")
    30 30
    31 
    -;;; Instead of reading /proc/version (which has some bugs with
    32 
    -;;; select() in Linux kernel 2.6.x) and instead of running uname -r,
    33 
    -;;; let's just get the info from uname().
    34 
    -(defun software-version ()
    35 
    -  "Returns a string describing version of the supporting software."
    36 
    -  (multiple-value-bind (sysname nodename release version)
    37 
    -      (unix:unix-uname)
    38 
    -    (declare (ignore sysname nodename))
    39 
    -    (concatenate 'string release " " version)))
    40 
    -
    41 
    -
    42 31 
     ;;; OS-Init initializes our operating-system interface.
    43 32 
     ;;;
    44 
    -(defun os-init () nil)
    33 
    +(defun os-init ()
    34 
    +  (setf *software-version* nil))
    35 
    +
    45 36
    37 
    +;;; GET-PAGE-SIZE  --  Interface
    38 
    +;;;
    39 
    +;;;    Return the system page size.
    40 
    +;;;
    41 
    +(defun get-page-size ()
    42 
    +  (multiple-value-bind (val err)
    43 
    +      (unix:unix-getpagesize)
    44 
    +    (unless val
    45 
    +      (error (intl:gettext "Getpagesize failed: ~A") (unix:get-unix-error-msg err)))
    46 
    +    val))
    46 47
    47 
    -;;; GET-SYSTEM-INFO  --  Interface
    48 
    -;;;
    49 
    -;;;    Return system time, user time and number of page faults.
    50 
    -;;;
    51 
    -(defun get-system-info ()
    52 
    -  (multiple-value-bind (err? utime stime maxrss ixrss idrss
    53 
    -			     isrss minflt majflt)
    54 
    -		       (unix:unix-getrusage unix:rusage_self)
    55 
    -    (declare (ignore maxrss ixrss idrss isrss minflt))
    56 
    -    (unless err?
    57 
    -      (error (intl:gettext "Unix system call getrusage failed: ~A.")
    58 
    -	     (unix:get-unix-error-msg utime)))
    59 
    -
    60 
    -    (values utime stime majflt)))

  • src/code/misc.lisp
    ... ... @@ -17,7 +17,7 @@
    17 17 
     (in-package "LISP")
    18 18 
     (intl:textdomain "cmucl")
    19 19
    20 
    -(export '(documentation *features* variable room
    20 
    +(export '(*features* variable room
    21 21 
     	  lisp-implementation-type lisp-implementation-version machine-type
    22 22 
     	  machine-version machine-instance software-type software-version
    23 23 
     	  short-site-name long-site-name dribble compiler-macro))
    ... ... @@ -81,12 +81,32 @@
    81 81 
       (unix:unix-gethostname))
    82 82
    83 83 
     (defvar *software-type* "Unix"
    84 
    -  "The value of SOFTWARE-TYPE.  Set in FOO-os.lisp.")
    84 
    +  _N"The value of SOFTWARE-TYPE.  Set in FOO-os.lisp.")
    85 85
    86 86 
     (defun software-type ()
    87 87 
       "Returns a string describing the supporting software."
    88 88 
       *software-type*)
    89 89
    90 
    +(defvar *software-version* nil
    91 
    +  _N"Version string for supporting software")
    92 
    +
    93 
    +(defun software-version ()
    94 
    +  _N"Returns a string describing version of the supporting software."
    95 
    +  (unless *software-version*
    96 
    +    (setf *software-version*
    97 
    +	  (let (version result)
    98 
    +	    (unwind-protect
    99 
    +		 (progn
    100 
    +		   (setf version
    101 
    +			 (alien:alien-funcall
    102 
    +			  (alien:extern-alien "os_software_version"
    103 
    +					      (function (alien:* c-call:c-string)))))
    104 
    +		   (setf result (alien:cast version c-call:c-string))))
    105 
    +	    (if (zerop (length result))
    106 
    +		"Unknown"
    107 
    +		result)))
    108 
    +    *software-version*))
    109 
    +
    90 110 
     (defvar *short-site-name* nil
    91 111 
       "The value of SHORT-SITE-NAME.  Set in library:site-init.lisp.")
    92 112

  • src/code/os.lisp
    1 
    +;;; -*- Package: SYSTEM -*-
    2 
    +;;;
    3 
    +;;; **********************************************************************
    4 
    +;;; This code was written as part of the CMU Common Lisp project at
    5 
    +;;; and has been placed in the public domain.
    6 
    +;;;
    7 
    +(ext:file-comment
    8 
    +  "$Header: src/code/os.lisp $")
    9 
    +;;;
    10 
    +;;; **********************************************************************
    11 
    +;;;
    12 
    +;;; OS interface functions for CMUCL.
    13 
    +;;;
    14 
    +;;; The code here is for OS functions that don't depend on the OS.
    15 
    +
    16 
    +(in-package "SYSTEM")
    17 
    +(use-package "EXTENSIONS")
    18 
    +(intl:textdomain "cmucl-linux-os")
    19 
    +
    20 
    +(export '(get-page-size))
    21 
    +
    22 
    +;;; GET-PAGE-SIZE  --  Interface
    23 
    +;;;
    24 
    +;;;    Return the system page size.
    25 
    +;;;
    26 
    +(defun get-page-size ()
    27 
    +  _N"Return the system page size"
    28 
    +  (let ((maybe-page-size (alien:alien-funcall
    29 
    +			  (alien:extern-alien "os_get_page_size"
    30 
    +					      (function c-call:long)))))
    31 
    +    (when (minusp maybe-page-size)
    32 
    +      (error (intl:gettext "get-page-size failed: ~A") (get-unix-error-msg err)))
    33 
    +    maybe-page-size))
    34 
    +
    35 
    +

  • src/code/sunos-os.lisp
    ... ... @@ -33,19 +33,6 @@
    33 33
    34 34 
     (setq *software-type* "SunOS")
    35 35
    36 
    -(defvar *software-version* nil "Version string for supporting software")
    37 
    -
    38 
    -(defun software-version ()
    39 
    -  "Returns a string describing version of the supporting software."
    40 
    -  (unless *software-version*
    41 
    -    (setf *software-version*
    42 
    -	  (multiple-value-bind (sysname nodename release version)
    43 
    -	      (unix:unix-uname)
    44 
    -	    (declare (ignore sysname nodename))
    45 
    -	    (concatenate 'string release " " version))))
    46 
    -  *software-version*)
    47 
    -
    48 
    -
    49 36 
     ;;; OS-INIT -- interface.
    50 37 
     ;;;
    51 38 
     ;;; Other OS dependent initializations.

  • src/code/unix.lisp
    ... ... @@ -2922,14 +2922,27 @@
    2922 2922 
     			  (function (* char))))
    2923 2923 
     	c-string))
    2924 2924
    2925 
    -;;; GET-PAGE-SIZE  --  Interface
    2925 
    +;;; GET-SYSTEM-INFO  --  Interface
    2926 2926 
     ;;;
    2927 
    -;;;    Return the system page size.
    2927 
    +;;;    Return system time, user time (in usec) and number of page
    2928 
    +;;;    faults.
    2928 2929 
     ;;;
    2929 
    -(defun get-page-size ()
    2930 
    -  (let ((maybe-page-size (alien-funcall
    2931 
    -			  (extern-alien "os_get_page_size"
    2932 
    -					(function c-call:long)))))
    2933 
    -    (when (minusp maybe-page-size)
    2934 
    -      (error (intl:gettext "get-page-size failed: ~A") (get-unix-error-msg err)))
    2935 
    -    maybe-page-size))
    2930 
    +(defun get-system-info ()
    2931 
    +  "Get system information consisting of the user time (in usec), the
    2932 
    +  system time (in usec) and the number of major page faults."
    2933 
    +  (with-alien ((utime int64-t 0)
    2934 
    +	       (stime int64-t 0)
    2935 
    +	       (major-fault c-call:long 0))
    2936 
    +    (let ((rc (alien-funcall
    2937 
    +	       (extern-alien "os_get_system_info"
    2938 
    +			     (function c-call:int
    2939 
    +				       (* int64-t)
    2940 
    +				       (* int64-t)
    2941 
    +				       (* c-call:long)))
    2942 
    +	       (addr utime)
    2943 
    +	       (addr stime)
    2944 
    +	       (addr major-fault))))
    2945 
    +      (when (minusp rc)
    2946 
    +	(error (intl:gettext "Unix system call getrusage failed: ~A.")
    2947 
    +	       (unix:get-unix-error-msg utime)))
    2948 
    +      (values utime stime major-fault))))

  • src/general-info/release-21e.md
    ... ... @@ -49,10 +49,11 @@ public domain.
    49 49 
         * ~~#108~~ Update ASDF.
    50 50 
         * ~~#112~~ CLX can't connect to X server via inet sockets.
    51 51 
         * ~~#113~~ REQUIRE on contribs can pull in the wrong things via ASDF.
    52 
    -    * ~~#121~~ Wrong column index in FILL-POINTER-OUTPUT-STREAM.
    53 
    -    * ~~#122~~ gcc 11 can't build cmucl.
    54 
    -    * ~~#124~~ directory with `:wild-inferiors` doesn't descend subdirectories.
    55 
    -    * ~~#125~~ Linux `unix-stat` returning incorrect values.
    52 
    +    * ~~#120~~ `SOFTWARE-VERSION` is implemented in C.
    53 
    +    * ~~#121~~ Wrong column index in FILL-POINTER-OUTPUT-STREAM
    54 
    +    * ~~#122~~ gcc 11 can't build cmucl
    55 
    +    * ~~#124~~ directory with `:wild-inferiors` doesn't descend subdirectories
    56 
    +    * ~~#125~~ Linux `unix-stat` returning incorrect values
    56 57 
         * ~~#127~~ Linux unix-getpwuid segfaults when given non-existent uid.
    57 58 
         * ~~#128~~ `QUIT` accepts an exit code.
    58 59 
         * ~~#130~~ Move file-author to C.

  • src/lisp/os-common.c
    ... ... @@ -15,7 +15,9 @@
    15 15 
     #include <stdio.h>
    16 16 
     #include <stdlib.h>
    17 17 
     #include <string.h>
    18 
    +#include <sys/resource.h>
    18 19 
     #include <sys/stat.h>
    20 
    +#include <sys/utsname.h>
    19 21 
     #include <unistd.h>
    20 22 
     #include <time.h>
    21 23
    ... ... @@ -811,3 +813,53 @@ os_get_page_size(void)
    811 813
    812 814 
         return sysconf(_SC_PAGESIZE);
    813 815 
     }
    816 
    +
    817 
    +/*
    818 
    + * Get system info consisting of the utime (in usec), the stime (in
    819 
    + * usec) and the number of major page faults.  The return value is the
    820 
    + * return code from getrusage.
    821 
    + */
    822 
    +int
    823 
    +os_get_system_info(int64_t* utime, int64_t* stime, long* major_fault)
    824 
    +{
    825 
    +    struct rusage usage;
    826 
    +    int rc;
    827 
    +
    828 
    +    *utime = 0;
    829 
    +    *stime = 0;
    830 
    +    *major_fault = 0;
    831 
    +
    832 
    +    rc = getrusage(RUSAGE_SELF, &usage);
    833 
    +    if (rc == 0) {
    834 
    +        *utime = usage.ru_utime.tv_sec * 1000000 + usage.ru_utime.tv_usec;
    835 
    +        *stime = usage.ru_stime.tv_sec * 1000000 + usage.ru_stime.tv_usec;
    836 
    +        *major_fault = usage.ru_majflt;
    837 
    +    }
    838 
    +
    839 
    +    return rc;
    840 
    +}
    841 
    +
    842 
    +/*
    843 
    + * Get the software version.  This is the same as "uname -r", the release.
    844 
    + * A pointer to a static string is returned. If uname fails, an empty
    845 
    + * string is returned.
    846 
    + */
    847 
    +char*
    848 
    +os_software_version(void)
    849 
    +{
    850 
    +    struct utsname uts;
    851 
    +    int status;
    852 
    +
    853 
    +    /*
    854 
    +     * Buffer large enough to hold the release.
    855 
    +     */
    856 
    +    static char result[sizeof(uts.release)];
    857 
    +    result[0] = '\0';
    858 
    +
    859 
    +    status = uname(&uts);
    860 
    +    if (status == 0) {
    861 
    +      strcpy(result, uts.release);
    862 
    +    }
    863 
    +
    864 
    +    return result;
    865 
    +}

  • src/tools/worldbuild.lisp
    ... ... @@ -147,6 +147,7 @@
    147 147 
     	'("target:code/bsd-os"))
    148 148 
         ,@(when (c:backend-featurep :Linux)
    149 149 
     	'("target:code/linux-os"))
    150 
    +    "target:code/os"
    150 151 
         "target:code/serve-event"
    151 152 
         "target:code/stream"
    152 153 
         "target:code/fd-stream"

  • src/tools/worldcom.lisp
    ... ... @@ -173,6 +173,7 @@
    173 173 
       (comf "target:code/bsd-os"))
    174 174 
     (when (c:backend-featurep :Linux)
    175 175 
       (comf "target:code/linux-os"))
    176 
    +(comf "target:code/os")
    176 177
    177 178 
     (when (c:backend-featurep :pmax)
    178 179 
       (comf "target:code/pmax-vm"))

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.common-lisp.net. Manage all notifications · Help