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

Contents of /src/code/mach.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (hide annotations)
Sat Apr 19 20:52:43 2003 UTC (10 years, 11 months ago) by gerd
Branch: MAIN
CVS Tags: double-double-array-base, release-19b-pre1, release-19b-pre2, merged-unicode-utf16-extfmt-2009-06-11, double-double-init-sparc-2, unicode-utf16-extfmt-2009-03-27, double-double-base, snapshot-2007-09, snapshot-2007-08, snapshot-2008-08, snapshot-2008-09, ppc_gencgc_snap_2006-01-06, sse2-packed-2008-11-12, snapshot-2008-05, snapshot-2008-06, snapshot-2008-07, snapshot-2007-05, snapshot-2008-01, snapshot-2008-02, snapshot-2008-03, snapshot-2006-11, snapshot-2006-10, double-double-init-sparc, snapshot-2006-12, unicode-string-buffer-impl-base, sse2-base, unicode-string-buffer-base, sse2-packed-base, amd64-dd-start, snapshot-2003-10, snapshot-2004-10, release-19f-pre1, snapshot-2008-12, snapshot-2008-11, intl-2-branch-base, snapshot-2004-08, snapshot-2004-09, remove_negative_zero_not_zero, snapshot-2007-01, snapshot-2007-02, snapshot-2004-05, snapshot-2004-06, snapshot-2004-07, release-19e, release-19d, double-double-init-ppc, release-19c, dynamic-extent-base, unicode-utf16-sync-2008-12, release-19c-base, label-2009-03-16, release-19f-base, merge-sse2-packed, mod-arith-base, sparc_gencgc_merge, merge-with-19f, snapshot-2004-12, snapshot-2004-11, unicode-snapshot-2009-05, unicode-snapshot-2009-06, amd64-merge-start, ppc_gencgc_snap_2005-12-17, double-double-init-%make-sparc, unicode-utf16-sync-2008-07, unicode-utf16-sync-2008-09, unicode-utf16-extfmts-sync-2008-12, prm-before-macosx-merge-tag, snapshot-2008-04, snapshot-2003-11, snapshot-2005-07, unicode-utf16-sync-label-2009-03-16, RELEASE_19f, snapshot-2007-03, release-20a-base, unicode-utf16-char-support-2009-03-26, unicode-utf16-char-support-2009-03-25, release-19a-base, unicode-utf16-extfmts-pre-sync-2008-11, snapshot-2008-10, sparc_gencgc, snapshot-2007-04, unicode-utf16-sync-2008-11, snapshot-2007-07, snapshot-2007-06, snapshot-2003-12, release-19a-pre1, release-19a-pre3, release-19a-pre2, pre-merge-intl-branch, release-19a, double-double-array-checkpoint, double-double-reader-checkpoint-1, release-19d-base, release-19e-pre1, double-double-irrat-end, release-19e-pre2, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, release-19d-pre2, release-19d-pre1, double-double-init-checkpoint-1, double-double-reader-base, label-2009-03-25, snapshot-2005-03, release-19b-base, double-double-init-x86, sse2-checkpoint-2008-10-01, snapshot-2005-11, double-double-sparc-checkpoint-1, snapshot-2004-04, sse2-merge-with-2008-11, sse2-merge-with-2008-10, snapshot-2005-10, RELEASE_20a, snapshot-2005-12, release-20a-pre1, snapshot-2005-01, snapshot-2009-11, snapshot-2009-12, unicode-utf16-extfmt-2009-06-11, portable-clx-import-2009-06-16, unicode-utf16-string-support, release-19c-pre1, release-19e-base, intl-branch-base, double-double-irrat-start, snapshot-2005-06, snapshot-2005-05, snapshot-2005-04, ppc_gencgc_snap_2005-05-14, snapshot-2005-02, unicode-utf16-base, portable-clx-base, snapshot-2005-09, snapshot-2005-08, lisp-executable-base, snapshot-2009-08, snapshot-2007-12, snapshot-2007-10, snapshot-2007-11, snapshot-2009-02, snapshot-2009-01, snapshot-2009-07, snapshot-2009-05, snapshot-2009-04, snapshot-2006-02, snapshot-2006-03, snapshot-2006-01, snapshot-2006-06, snapshot-2006-07, snapshot-2006-04, snapshot-2006-05, pre-telent-clx, snapshot-2006-08, snapshot-2006-09
Branch point for: release-19b-branch, double-double-reader-branch, double-double-array-branch, mod-arith-branch, RELEASE-19F-BRANCH, portable-clx-branch, sparc_gencgc_branch, unicode-string-buffer-branch, dynamic-extent, release-19d-branch, ppc_gencgc_branch, sse2-packed-branch, lisp-executable, RELEASE-20A-BRANCH, amd64-dd-branch, double-double-branch, unicode-string-buffer-impl-branch, intl-branch, unicode-utf16-branch, release-19e-branch, sse2-branch, release-19a-branch, release-19c-branch, intl-2-branch, unicode-utf16-extfmt-branch
Changes since 1.4: +2 -2 lines
	Add destructuring support to &REST, &BODY, &WHOLE.  Detected
	by Paul Dietz' ANSI tests.

	* src/code/defmacro.lisp (parse-defmacro-lambda-list): Add
	&parse-body, replacing &body (<body> <decls> <doc>).  Add
	destructuring support to &rest, &body, &whole.

	* src/code/eval.lisp (lambda-list-keywords): Add &parse-body.

	* src/code/exports.lisp ("EXTENSIONS"): Export &parse-body.

	* src/hemlock/table.lisp (do-words, with-folded-string):
	* src/hemlock/macros.lisp (with-pop-up-display):
	* src/compiler/macros.lisp (deftransform):
	* src/compiler/ir1tran.lisp (symbol-macrolet, let, locally)
	(let*, flet, labels) <ir1-translator>:
	* src/code/package.lisp (do-symbols, do-external-symbols)
	(do-all-symbols):
	* src/code/macros.lisp (defun, prog, prog*, with-open-file)
	(with-open-stream, with-input-from-string)
	(with-output-to-string, do, do*):
	* src/code/mach.lisp (gr-bind):
	* src/code/extensions.lisp (do-anonymous, do-hash, defun-cached):
	Use &parse-body instead of &body.
1 wlott 1.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 gerd 1.5 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/mach.lisp,v 1.5 2003/04/19 20:52:43 gerd Rel $")
9 wlott 1.1 ;;;
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    
21 wlott 1.2 (export '(port mach-task_self mach-task_data mach-task_notify
22     kern-success get-mach-error-msg
23     gr-error gr-call gr-call* gr-bind
24 wlott 1.1 vm_allocate vm_copy vm_deallocate vm_statistics))
25    
26 wlott 1.2
27     ;;;; Standard ports.
28    
29 wlott 1.1 (def-alien-type port int)
30    
31 wlott 1.2 (def-alien-routine ("task_self" mach-task_self) port)
32     (def-alien-routine ("thread_reply" mach-task_data) port)
33     (def-alien-routine ("task_notify" mach-task_notify) port)
34    
35    
36 wlott 1.1
37 wlott 1.2 ;;;; Return codes.
38 wlott 1.1
39 wlott 1.2 (def-alien-type kern-return int)
40    
41     (defconstant kern-success 0)
42     (defconstant kern-invalid-address 1)
43     (defconstant kern-protection-failure 2)
44     (defconstant kern-no-space 3)
45     (defconstant kern-invalid-argument 4)
46     (defconstant kern-failure 5)
47     (defconstant kern-resource-shortage 6)
48     (defconstant kern-not-receiver 7)
49     (defconstant kern-no-access 8)
50     (defconstant kern-memory-failure 9)
51     (defconstant kern-memory-error 10)
52     (defconstant kern-already-in-set 11)
53     (defconstant kern-not-in-set 12)
54     (defconstant kern-name-exists 13)
55     (defconstant kern-aborted 14)
56     (defconstant kern-memory-present 23)
57    
58     (def-alien-routine ("mach_error_string" get-mach-error-msg) c-string
59 wlott 1.3 (errno kern-return))
60 wlott 1.2
61     ;;; GR-Error -- Public
62     ;;;
63     (defun gr-error (function gr &optional context)
64     "Signal an error indicating that Function returned code GR. If the code
65     is success, then do nothing."
66     (unless (eql gr kern-success)
67     (error "~S~@[ ~A~], ~(~A~)." function context (get-mach-error-msg gr))))
68    
69     ;;; GR-Call -- Public
70     ;;;
71     (defmacro gr-call (fun &rest args)
72     "GR-Call Function {Arg}*
73     Call the function with the specified Args and signal an error if the
74     first value returned is not mach:kern-success. Nil is returned."
75     (let ((n-gr (gensym)))
76     `(let ((,n-gr (,fun ,@args)))
77     (unless (eql ,n-gr kern-success) (gr-error ',fun ,n-gr)))))
78    
79     ;;; GR-Call* -- Public
80     ;;;
81     (defmacro gr-call* (fun &rest args)
82     "GR-Call* Function {Arg}*
83     Call the function with the specified Args and signal an error if the
84     first value returned is not mach:kern-success. The second value is
85     returned."
86     (let ((n-gr (gensym))
87     (n-res (gensym)))
88     `(multiple-value-bind (,n-gr ,n-res) (,fun ,@args)
89     (unless (eql ,n-gr kern-success) (gr-error ',fun ,n-gr))
90     ,n-res)))
91    
92     ;;; GR-Bind -- Public
93     ;;;
94 gerd 1.5 (defmacro gr-bind (vars (fun . args) &parse-body (body decls))
95 wlott 1.2 "GR-Bind ({Var}*) (Function {Arg}*) {Form}*
96     Call the function with the specified Args and signal an error if the
97     first value returned is not mach:Kern-Success. If the call succeeds,
98     the Forms are evaluated with remaining return values bound to the
99     Vars."
100     (let ((n-gr (gensym)))
101     `(multiple-value-bind (,n-gr ,@vars) (,fun ,@args)
102     ,@decls
103     (unless (eql ,n-gr kern-success) (gr-error ',fun ,n-gr))
104     ,@body)))
105 wlott 1.1
106    
107    
108     ;;;; VM routines.
109    
110     (export '(vm_allocate vm_copy vm_deallocate vm_statistics))
111    
112     (def-alien-routine ("vm_allocate" vm_allocate) int
113     (task port)
114     (address system-area-pointer :in-out)
115     (size unsigned-long)
116     (anywhere boolean))
117    
118     (def-alien-routine ("vm_copy" vm_copy) int
119     (task port)
120     (source system-area-pointer)
121     (count unsigned-long)
122     (dest system-area-pointer))
123    
124     (def-alien-routine ("vm_deallocate" vm_deallocate) int
125     (task port)
126     (address system-area-pointer)
127     (size unsigned-long))
128    
129    
130     (def-alien-type nil
131     (struct vm_statistics
132     (pagesize long)
133     (free_count long)
134     (active_count long)
135     (inactive_count long)
136     (wire_count long)
137     (zero_fill_count long)
138     (reactivations long)
139     (pageins long)
140     (pageouts long)
141     (faults long)
142     (cow_faults long)
143     (lookups long)
144     (hits long)))
145    
146     (defun vm_statistics (task)
147     (with-alien ((vm_stats (struct vm_statistics)))
148     (values
149     (alien-funcall (extern-alien "vm_statistics"
150     (function int
151     port
152     (* (struct vm_statistics))))
153     task (alien-sap vm_stats))
154     (slot vm_stats 'pagesize)
155     (slot vm_stats 'free_count)
156     (slot vm_stats 'active_count)
157     (slot vm_stats 'inactive_count)
158     (slot vm_stats 'wire_count)
159     (slot vm_stats 'zero_fill_count)
160     (slot vm_stats 'reactivations)
161     (slot vm_stats 'pageins)
162     (slot vm_stats 'pageouts)
163     (slot vm_stats 'faults)
164     (slot vm_stats 'cow_faults)
165     (slot vm_stats 'lookups)
166     (slot vm_stats 'hits))))

  ViewVC Help
Powered by ViewVC 1.1.5