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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.16 - (show annotations)
Wed Dec 22 02:12:51 2010 UTC (3 years, 3 months ago) by rtoy
Branch: MAIN
CVS Tags: GIT-CONVERSION, cross-sol-x86-merged, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, HEAD
Changes since 1.15: +6 -1 lines
Merge changes from cross-sol-x86-2010-12-20 which adds support for
Solaris/x86.  There should be no functional changes for either other
x86 ports or for the sparc port.
1 ;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*-
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/sunos-os.lisp,v 1.16 2010/12/22 02:12:51 rtoy Exp $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; OS interface functions for CMUCL under SunOS. From Miles Bader and David
13 ;;; Axmark.
14 ;;;
15
16 (in-package "SYSTEM")
17 (use-package "EXTENSIONS")
18 (intl:textdomain "cmucl-sunos-os")
19
20 (export '(get-system-info get-page-size os-init))
21
22 (pushnew :sunos *features*)
23
24 #+solaris
25 (register-lisp-feature :solaris)
26 #+svr4
27 (register-lisp-feature :svr4)
28
29 #+executable
30 (register-lisp-runtime-feature :executable)
31
32 (setq *software-type* "SunOS")
33
34 (defvar *software-version* nil "Version string for supporting software")
35
36 (defun software-version ()
37 "Returns a string describing version of the supporting software."
38 (unless *software-version*
39 (setf *software-version*
40 (multiple-value-bind (sysname nodename release version)
41 (unix:unix-uname)
42 (declare (ignore sysname nodename))
43 (concatenate 'string release " " version))))
44 *software-version*)
45
46
47 ;;; OS-INIT -- interface.
48 ;;;
49 ;;; Other OS dependent initializations.
50 ;;;
51 (defun os-init ()
52 ;; Decache version on save, because it might not be the same when we restart.
53 (setf *software-version* nil))
54
55 ;;; GET-SYSTEM-INFO -- Interface
56 ;;;
57 ;;; Return system time, user time and number of page faults.
58 ;;;
59 #-(and sparc svr4)
60 (defun get-system-info ()
61 (multiple-value-bind
62 (err? utime stime maxrss ixrss idrss isrss minflt majflt)
63 (unix:unix-getrusage unix:rusage_self)
64 (declare (ignore maxrss ixrss idrss isrss minflt))
65 (cond ((null err?)
66 (error (intl:gettext "Unix system call getrusage failed: ~A.")
67 (unix:get-unix-error-msg utime)))
68 (T
69 (values utime stime majflt)))))
70
71 ;;; GET-SYSTEM-INFO -- Interface
72 ;;;
73 ;;; Return system time, user time and number of page faults.
74 ;;;
75 #+(and sparc svr4)
76 (defun get-system-info ()
77 (multiple-value-bind
78 (err? utime stime cutime cstime)
79 (unix:unix-times)
80 (declare (ignore err? cutime cstime))
81 ;; Return times in microseconds; page fault statistics not supported.
82 (values (* utime 10000) (* stime 10000) 0)))
83
84 ;;; GET-PAGE-SIZE -- Interface
85 ;;;
86 ;;; Return the system page size.
87 ;;;
88 (defun get-page-size ()
89 (multiple-value-bind (val err)
90 (unix:unix-getpagesize)
91 (unless val
92 (error (intl:gettext "Getpagesize failed: ~A") (unix:get-unix-error-msg err)))
93 val))

  ViewVC Help
Powered by ViewVC 1.1.5