/[cmucl]/src/code/mach.lisp
ViewVC logotype

Contents of /src/code/mach.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.6 - (show annotations)
Fri Mar 19 15:18:59 2010 UTC (4 years ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, post-merge-intl-branch, release-20b-pre1, release-20b-pre2, sparc-tramp-assem-2010-07-19, GIT-CONVERSION, cross-sol-x86-merged, RELEASE_20b, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-08, cross-sol-x86-2010-12-20, cross-sparc-branch-base, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, sparc-tramp-assem-branch, cross-sol-x86-branch
Changes since 1.5: +2 -1 lines
Merge intl-branch 2010-03-18 to HEAD.  To build, you need to use
boot-2010-02-1 as the bootstrap file.  You should probably also use
the new -P option for build.sh to generate and update the po files
while building.
1 ;;; -*- Package: MACH -*-
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/mach.lisp,v 1.6 2010/03/19 15:18:59 rtoy Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; This file contains the low-level support for MACH features not found
13 ;;; in UNIX.
14 ;;;
15
16 (in-package "MACH")
17 (use-package "ALIEN")
18 (use-package "C-CALL")
19 (use-package "SYSTEM")
20 (intl:textdomain "cmucl")
21
22 (export '(port mach-task_self mach-task_data mach-task_notify
23 kern-success get-mach-error-msg
24 gr-error gr-call gr-call* gr-bind
25 vm_allocate vm_copy vm_deallocate vm_statistics))
26
27
28 ;;;; Standard ports.
29
30 (def-alien-type port int)
31
32 (def-alien-routine ("task_self" mach-task_self) port)
33 (def-alien-routine ("thread_reply" mach-task_data) port)
34 (def-alien-routine ("task_notify" mach-task_notify) port)
35
36
37
38 ;;;; Return codes.
39
40 (def-alien-type kern-return int)
41
42 (defconstant kern-success 0)
43 (defconstant kern-invalid-address 1)
44 (defconstant kern-protection-failure 2)
45 (defconstant kern-no-space 3)
46 (defconstant kern-invalid-argument 4)
47 (defconstant kern-failure 5)
48 (defconstant kern-resource-shortage 6)
49 (defconstant kern-not-receiver 7)
50 (defconstant kern-no-access 8)
51 (defconstant kern-memory-failure 9)
52 (defconstant kern-memory-error 10)
53 (defconstant kern-already-in-set 11)
54 (defconstant kern-not-in-set 12)
55 (defconstant kern-name-exists 13)
56 (defconstant kern-aborted 14)
57 (defconstant kern-memory-present 23)
58
59 (def-alien-routine ("mach_error_string" get-mach-error-msg) c-string
60 (errno kern-return))
61
62 ;;; GR-Error -- Public
63 ;;;
64 (defun gr-error (function gr &optional context)
65 "Signal an error indicating that Function returned code GR. If the code
66 is success, then do nothing."
67 (unless (eql gr kern-success)
68 (error "~S~@[ ~A~], ~(~A~)." function context (get-mach-error-msg gr))))
69
70 ;;; GR-Call -- Public
71 ;;;
72 (defmacro gr-call (fun &rest args)
73 "GR-Call Function {Arg}*
74 Call the function with the specified Args and signal an error if the
75 first value returned is not mach:kern-success. Nil is returned."
76 (let ((n-gr (gensym)))
77 `(let ((,n-gr (,fun ,@args)))
78 (unless (eql ,n-gr kern-success) (gr-error ',fun ,n-gr)))))
79
80 ;;; GR-Call* -- Public
81 ;;;
82 (defmacro gr-call* (fun &rest args)
83 "GR-Call* Function {Arg}*
84 Call the function with the specified Args and signal an error if the
85 first value returned is not mach:kern-success. The second value is
86 returned."
87 (let ((n-gr (gensym))
88 (n-res (gensym)))
89 `(multiple-value-bind (,n-gr ,n-res) (,fun ,@args)
90 (unless (eql ,n-gr kern-success) (gr-error ',fun ,n-gr))
91 ,n-res)))
92
93 ;;; GR-Bind -- Public
94 ;;;
95 (defmacro gr-bind (vars (fun . args) &parse-body (body decls))
96 "GR-Bind ({Var}*) (Function {Arg}*) {Form}*
97 Call the function with the specified Args and signal an error if the
98 first value returned is not mach:Kern-Success. If the call succeeds,
99 the Forms are evaluated with remaining return values bound to the
100 Vars."
101 (let ((n-gr (gensym)))
102 `(multiple-value-bind (,n-gr ,@vars) (,fun ,@args)
103 ,@decls
104 (unless (eql ,n-gr kern-success) (gr-error ',fun ,n-gr))
105 ,@body)))
106
107
108
109 ;;;; VM routines.
110
111 (export '(vm_allocate vm_copy vm_deallocate vm_statistics))
112
113 (def-alien-routine ("vm_allocate" vm_allocate) int
114 (task port)
115 (address system-area-pointer :in-out)
116 (size unsigned-long)
117 (anywhere boolean))
118
119 (def-alien-routine ("vm_copy" vm_copy) int
120 (task port)
121 (source system-area-pointer)
122 (count unsigned-long)
123 (dest system-area-pointer))
124
125 (def-alien-routine ("vm_deallocate" vm_deallocate) int
126 (task port)
127 (address system-area-pointer)
128 (size unsigned-long))
129
130
131 (def-alien-type nil
132 (struct vm_statistics
133 (pagesize long)
134 (free_count long)
135 (active_count long)
136 (inactive_count long)
137 (wire_count long)
138 (zero_fill_count long)
139 (reactivations long)
140 (pageins long)
141 (pageouts long)
142 (faults long)
143 (cow_faults long)
144 (lookups long)
145 (hits long)))
146
147 (defun vm_statistics (task)
148 (with-alien ((vm_stats (struct vm_statistics)))
149 (values
150 (alien-funcall (extern-alien "vm_statistics"
151 (function int
152 port
153 (* (struct vm_statistics))))
154 task (alien-sap vm_stats))
155 (slot vm_stats 'pagesize)
156 (slot vm_stats 'free_count)
157 (slot vm_stats 'active_count)
158 (slot vm_stats 'inactive_count)
159 (slot vm_stats 'wire_count)
160 (slot vm_stats 'zero_fill_count)
161 (slot vm_stats 'reactivations)
162 (slot vm_stats 'pageins)
163 (slot vm_stats 'pageouts)
164 (slot vm_stats 'faults)
165 (slot vm_stats 'cow_faults)
166 (slot vm_stats 'lookups)
167 (slot vm_stats 'hits))))

  ViewVC Help
Powered by ViewVC 1.1.5