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

Contents of /src/code/sap.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.4 - (show annotations)
Wed Jan 29 06:34:19 1992 UTC (22 years, 2 months ago) by wlott
Branch: MAIN
Changes since 1.3: +2 -2 lines
Changed the import of a few kernel symbols to a use-package of kernel.
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 ;;; If you want to use this code or any part of CMU Common Lisp, please contact
7 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
8 ;;;
9 (ext:file-comment
10 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/sap.lisp,v 1.4 1992/01/29 06:34:19 wlott Exp $")
11 ;;;
12 ;;; **********************************************************************
13 ;;;
14 ;;; This file holds the support for System Area Pointers (saps).
15 ;;;
16 (in-package "SYSTEM")
17
18 (export '(system-area-pointer sap-ref-8 sap-ref-16 sap-ref-32 sap-ref-sap
19 signed-sap-ref-8 signed-sap-ref-16 signed-sap-ref-32
20 sap+ sap- sap< sap<= sap= sap>= sap>))
21
22 (in-package "KERNEL")
23 (export '(%set-sap-ref-sap %set-sap-ref-32 %set-sap-ref-16
24 %set-sap-ref-8 %set-sap-ref-single %set-sap-ref-double))
25 (in-package "SYSTEM")
26
27 (use-package "KERNEL")
28
29
30
31 ;;;; Primitive SAP operations.
32
33 (defun sap< (x y)
34 "Return T iff the SAP X points to a smaller address then the SAP Y."
35 (declare (type system-area-pointer x y))
36 (sap< x y))
37
38 (defun sap<= (x y)
39 "Return T iff the SAP X points to a smaller or the same address as
40 the SAP Y."
41 (declare (type system-area-pointer x y))
42 (sap<= x y))
43
44 (defun sap= (x y)
45 "Return T iff the SAP X points to the same address as the SAP Y."
46 (declare (type system-area-pointer x y))
47 (sap= x y))
48
49 (defun sap>= (x y)
50 "Return T iff the SAP X points to a larger or the same address as
51 the SAP Y."
52 (declare (type system-area-pointer x y))
53 (sap>= x y))
54
55 (defun sap> (x y)
56 "Return T iff the SAP X points to a larger address then the SAP Y."
57 (declare (type system-area-pointer x y))
58 (pointer> x y))
59
60 (defun sap+ (sap offset)
61 "Return a new sap OFFSET bytes from SAP."
62 (declare (type system-area-pointer sap)
63 (fixnum offset))
64 (sap+ sap offset))
65
66 (defun sap- (sap1 sap2)
67 "Return the byte offset between SAP1 and SAP2."
68 (declare (type system-area-pointer sap1 sap2))
69 (sap- sap1 sap2))
70
71 (defun sap-int (sap)
72 "Converts a System Area Pointer into an integer."
73 (declare (type system-area-pointer sap))
74 (sap-int sap))
75
76 (defun int-sap (int)
77 "Converts an integer into a System Area Pointer."
78 (declare (type (unsigned-byte #.vm:word-bits) int))
79 (int-sap int))
80
81 (defun sap-ref-8 (sap offset)
82 "Returns the 8-bit byte at OFFSET bytes from SAP."
83 (declare (type system-area-pointer sap)
84 (type index offset))
85 (sap-ref-8 sap offset))
86
87 (defun sap-ref-16 (sap offset)
88 "Returns the 16-bit word at OFFSET half-words from SAP."
89 (declare (type system-area-pointer sap)
90 (type index offset))
91 (sap-ref-16 sap offset))
92
93 (defun sap-ref-32 (sap offset)
94 "Returns the 32-bit dualword at OFFSET words from SAP."
95 (declare (type system-area-pointer sap)
96 (type index offset))
97 (sap-ref-32 sap offset))
98
99 (defun sap-ref-sap (sap offset)
100 "Returns the 32-bit system-area-pointer at OFFSET words from SAP."
101 (declare (type system-area-pointer sap)
102 (type index offset))
103 (sap-ref-sap sap offset))
104
105 (defun sap-ref-single (sap offset)
106 "Returns the 32-bit single-float at OFFSET words from SAP."
107 (declare (type system-area-pointer sap)
108 (type index offset))
109 (sap-ref-single sap offset))
110
111 (defun sap-ref-double (sap offset)
112 "Returns the 64-bit double-float at OFFSET words from SAP."
113 (declare (type system-area-pointer sap)
114 (type index offset))
115 (sap-ref-double sap offset))
116
117 (defun signed-sap-ref-8 (sap offset)
118 "Returns the signed 8-bit byte at Offset bytes from SAP."
119 (declare (type system-area-pointer sap)
120 (type index offset))
121 (signed-sap-ref-8 sap offset))
122
123 (defun signed-sap-ref-16 (sap offset)
124 "Returns the signed 16-bit word at Offset words from SAP."
125 (declare (type system-area-pointer sap)
126 (type index offset))
127 (signed-sap-ref-16 sap offset))
128
129 (defun signed-sap-ref-32 (sap offset)
130 "Returns the signed 32-bit dualword at Offset words from SAP."
131 (declare (type system-area-pointer sap)
132 (type index offset))
133 (signed-sap-ref-32 sap offset))
134
135 (defun %set-sap-ref-8 (sap offset new-value)
136 (declare (type system-area-pointer sap)
137 (type index offset)
138 (type (or (signed-byte 8) (unsigned-byte 8)) new-value))
139 (setf (sap-ref-8 sap offset) new-value))
140
141 (defun %set-sap-ref-16 (sap offset new-value)
142 (declare (type system-area-pointer sap)
143 (type index offset)
144 (type (or (signed-byte 16) (unsigned-byte 16)) new-value))
145 (setf (sap-ref-16 sap offset) new-value))
146
147 (defun %set-sap-ref-32 (sap offset new-value)
148 (declare (type system-area-pointer sap)
149 (type index offset)
150 (type (or (signed-byte 32) (unsigned-byte 32)) new-value))
151 (if (minusp new-value)
152 (truly-the (signed-byte 32) (setf (sap-ref-32 sap offset) new-value))
153 (truly-the (unsigned-byte 32) (setf (sap-ref-32 sap offset) new-value))))
154
155 (defun %set-sap-ref-sap (sap offset new-value)
156 (declare (type system-area-pointer sap new-value)
157 (type index offset))
158 (setf (sap-ref-sap sap offset) new-value))
159
160 (defun %set-sap-ref-single (sap offset new-value)
161 (declare (type system-area-pointer sap)
162 (type index offset)
163 (type single-float new-value))
164 (setf (sap-ref-single sap offset) new-value))
165
166 (defun %set-sap-ref-double (sap offset new-value)
167 (declare (type system-area-pointer sap)
168 (type index offset)
169 (type double-float new-value))
170 (setf (sap-ref-double sap offset) new-value))
171
172
173
174 ;;;; System memory allocation.
175
176 ;;; ALLOCATE-SYSTEM-MEMORY -- public
177 ;;;
178 ;;; Allocate random memory from the system area.
179 ;;;
180 (defun allocate-system-memory (bytes)
181 (declare (type index bytes))
182 (gr-call* mach:vm_allocate *task-self* (int-sap 0) bytes t))
183
184 ;;; REALLOCATE-SYSTEM-MEMORY -- public
185 ;;;
186 ;;; Either allocate more memory at the end of this block, or allocate a new
187 ;;; block and move the old memory into it.
188 ;;;
189 (defun reallocate-system-memory (old old-size new-size)
190 (declare (type system-area-pointer old)
191 (type index old-size new-size))
192 ;; ### Got to work the page size into this somehow. The vm_allocate
193 ;; will fail much more often than it otherwise would 'cause if the old
194 ;; block stops in the middle of a page, we can't extend it.
195 (if (eql (mach:vm_allocate *task-self*
196 (sap+ old old-size)
197 (- new-size old-size)
198 nil)
199 mach:kern-success)
200 old
201 (let ((new (allocate-system-memory new-size)))
202 (declare (type system-area-pointer new))
203 (system-area-copy old 0 new 0 (* old-size vm:byte-bits))
204 (deallocate-system-memory old old-size)
205 new)))
206
207 ;;; DEALLOCATE-SYSTEM-MEMORY -- public
208 ;;;
209 ;;; Deallocate that memory.
210 ;;;
211 (defun deallocate-system-memory (addr bytes)
212 (declare (type system-area-pointer addr)
213 (type index bytes))
214 (gr-call* mach:vm_deallocate *task-self* addr bytes))
215
216

  ViewVC Help
Powered by ViewVC 1.1.5