/[cmucl]/src/code/linux-os.lisp
ViewVC logotype

Contents of /src/code/linux-os.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.6 - (show annotations)
Wed Jul 18 09:50:24 2007 UTC (6 years, 9 months ago) by cshapiro
Branch: MAIN
CVS Tags: snapshot-2007-09, snapshot-2007-08, snapshot-2008-08, snapshot-2008-09, sse2-packed-2008-11-12, snapshot-2008-05, snapshot-2008-06, snapshot-2008-07, snapshot-2008-01, snapshot-2008-02, snapshot-2008-03, sse2-base, sse2-packed-base, release-19f-pre1, snapshot-2008-12, snapshot-2008-11, release-19e, unicode-utf16-sync-2008-12, label-2009-03-16, release-19f-base, merge-sse2-packed, merge-with-19f, unicode-utf16-sync-2008-07, unicode-utf16-sync-2008-09, unicode-utf16-extfmts-sync-2008-12, snapshot-2008-04, unicode-utf16-sync-label-2009-03-16, RELEASE_19f, unicode-utf16-extfmts-pre-sync-2008-11, snapshot-2008-10, unicode-utf16-sync-2008-11, release-19e-pre1, release-19e-pre2, sse2-checkpoint-2008-10-01, sse2-merge-with-2008-11, sse2-merge-with-2008-10, unicode-utf16-string-support, release-19e-base, unicode-utf16-base, snapshot-2007-12, snapshot-2007-10, snapshot-2007-11, snapshot-2009-02, snapshot-2009-01, pre-telent-clx
Branch point for: RELEASE-19F-BRANCH, sse2-packed-branch, unicode-utf16-branch, release-19e-branch, sse2-branch, unicode-utf16-extfmt-branch
Changes since 1.5: +2 -2 lines
Fix a typo.
1 ;;; -*- Package: SYSTEM -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/linux-os.lisp,v 1.6 2007/07/18 09:50:24 cshapiro Exp $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; OS interface functions for CMUCL under Linux.
13 ;;;
14 ;;; Written and maintained mostly by Skef Wholey and Rob MacLachlan.
15 ;;; Scott Fahlman, Dan Aronson, and Steve Handerson did stuff here, too.
16 ;;;
17 ;;; Derived from mach-os.lisp by Paul Werkowski
18
19 (in-package "SYSTEM")
20 (use-package "EXTENSIONS")
21 (export '(get-system-info get-page-size os-init))
22
23 (register-lisp-feature :linux)
24 (register-lisp-feature :elf)
25 (register-lisp-runtime-feature :executable)
26
27 (setq *software-type* "Linux")
28
29 ;;; We use READ-SEQUENCE instead of READ-LINE to work around a bug in
30 ;;; the proc file system on Linux kernel 2.6.x. The select() system
31 ;;; call does not work correctly on certain files; it never reports
32 ;;; that data is available for reading. Since CMUCL's fd-streams use
33 ;;; select(), as a part of the SERVE-EVENT mechanism, normal I/O (for
34 ;;; instance with READ-CHAR or READ-LINE) will fail on these files.
35 ;;; Luckily READ-SEQUENCE does not suffer from this problem.
36 ;;;
37 ;;; We could also call "uname -r" here, but using the filesystem-based
38 ;;; interface seems cleaner.
39 (defun software-version ()
40 "Returns a string describing version of the supporting software."
41 (when (probe-file "/proc/version")
42 (with-open-file (f "/proc/version")
43 (let* ((buf (make-string 1024))
44 (count (read-sequence buf f :end 1024)))
45 (subseq buf 0 (1- count))))))
46
47
48 ;;; OS-Init initializes our operating-system interface.
49 ;;;
50 (defun os-init () nil)
51
52
53 ;;; GET-SYSTEM-INFO -- Interface
54 ;;;
55 ;;; Return system time, user time and number of page faults.
56 ;;;
57 (defun get-system-info ()
58 (multiple-value-bind (err? utime stime maxrss ixrss idrss
59 isrss minflt majflt)
60 (unix:unix-getrusage unix:rusage_self)
61 (declare (ignore maxrss ixrss idrss isrss minflt))
62 (unless err?
63 (error "Unix system call getrusage failed: ~A."
64 (unix:get-unix-error-msg utime)))
65
66 (values utime stime majflt)))
67
68
69 ;;; GET-PAGE-SIZE -- Interface
70 ;;;
71 ;;; Return the system page size.
72 ;;;
73 (defun get-page-size ()
74 (multiple-value-bind (val err)
75 (unix:unix-getpagesize)
76 (unless val
77 (error "Getpagesize failed: ~A" (unix:get-unix-error-msg err)))
78 val))
79

  ViewVC Help
Powered by ViewVC 1.1.5