Newer
Older
;;; -*- Package: MACH -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of CMU Common Lisp, please contact
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/mach.lisp,v 1.3 1992/02/15 13:00:05 wlott Exp $")
;;;
;;; **********************************************************************
;;;
;;; This file contains the low-level support for MACH features not found
;;; in UNIX.
;;;
(in-package "MACH")
(use-package "ALIEN")
(use-package "C-CALL")
(use-package "SYSTEM")
(export '(port mach-task_self mach-task_data mach-task_notify
kern-success get-mach-error-msg
gr-error gr-call gr-call* gr-bind
;;;; Standard ports.
(def-alien-routine ("task_self" mach-task_self) port)
(def-alien-routine ("thread_reply" mach-task_data) port)
(def-alien-routine ("task_notify" mach-task_notify) port)
;;;; Return codes.
(def-alien-type kern-return int)
(defconstant kern-success 0)
(defconstant kern-invalid-address 1)
(defconstant kern-protection-failure 2)
(defconstant kern-no-space 3)
(defconstant kern-invalid-argument 4)
(defconstant kern-failure 5)
(defconstant kern-resource-shortage 6)
(defconstant kern-not-receiver 7)
(defconstant kern-no-access 8)
(defconstant kern-memory-failure 9)
(defconstant kern-memory-error 10)
(defconstant kern-already-in-set 11)
(defconstant kern-not-in-set 12)
(defconstant kern-name-exists 13)
(defconstant kern-aborted 14)
(defconstant kern-memory-present 23)
(def-alien-routine ("mach_error_string" get-mach-error-msg) c-string
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
;;; GR-Error -- Public
;;;
(defun gr-error (function gr &optional context)
"Signal an error indicating that Function returned code GR. If the code
is success, then do nothing."
(unless (eql gr kern-success)
(error "~S~@[ ~A~], ~(~A~)." function context (get-mach-error-msg gr))))
;;; GR-Call -- Public
;;;
(defmacro gr-call (fun &rest args)
"GR-Call Function {Arg}*
Call the function with the specified Args and signal an error if the
first value returned is not mach:kern-success. Nil is returned."
(let ((n-gr (gensym)))
`(let ((,n-gr (,fun ,@args)))
(unless (eql ,n-gr kern-success) (gr-error ',fun ,n-gr)))))
;;; GR-Call* -- Public
;;;
(defmacro gr-call* (fun &rest args)
"GR-Call* Function {Arg}*
Call the function with the specified Args and signal an error if the
first value returned is not mach:kern-success. The second value is
returned."
(let ((n-gr (gensym))
(n-res (gensym)))
`(multiple-value-bind (,n-gr ,n-res) (,fun ,@args)
(unless (eql ,n-gr kern-success) (gr-error ',fun ,n-gr))
,n-res)))
;;; GR-Bind -- Public
;;;
(defmacro gr-bind (vars (fun . args) &body (body decls))
"GR-Bind ({Var}*) (Function {Arg}*) {Form}*
Call the function with the specified Args and signal an error if the
first value returned is not mach:Kern-Success. If the call succeeds,
the Forms are evaluated with remaining return values bound to the
Vars."
(let ((n-gr (gensym)))
`(multiple-value-bind (,n-gr ,@vars) (,fun ,@args)
,@decls
(unless (eql ,n-gr kern-success) (gr-error ',fun ,n-gr))
,@body)))
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
;;;; VM routines.
(export '(vm_allocate vm_copy vm_deallocate vm_statistics))
(def-alien-routine ("vm_allocate" vm_allocate) int
(task port)
(address system-area-pointer :in-out)
(size unsigned-long)
(anywhere boolean))
(def-alien-routine ("vm_copy" vm_copy) int
(task port)
(source system-area-pointer)
(count unsigned-long)
(dest system-area-pointer))
(def-alien-routine ("vm_deallocate" vm_deallocate) int
(task port)
(address system-area-pointer)
(size unsigned-long))
(def-alien-type nil
(struct vm_statistics
(pagesize long)
(free_count long)
(active_count long)
(inactive_count long)
(wire_count long)
(zero_fill_count long)
(reactivations long)
(pageins long)
(pageouts long)
(faults long)
(cow_faults long)
(lookups long)
(hits long)))
(defun vm_statistics (task)
(with-alien ((vm_stats (struct vm_statistics)))
(values
(alien-funcall (extern-alien "vm_statistics"
(function int
port
(* (struct vm_statistics))))
task (alien-sap vm_stats))
(slot vm_stats 'pagesize)
(slot vm_stats 'free_count)
(slot vm_stats 'active_count)
(slot vm_stats 'inactive_count)
(slot vm_stats 'wire_count)
(slot vm_stats 'zero_fill_count)
(slot vm_stats 'reactivations)
(slot vm_stats 'pageins)
(slot vm_stats 'pageouts)
(slot vm_stats 'faults)
(slot vm_stats 'cow_faults)
(slot vm_stats 'lookups)
(slot vm_stats 'hits))))