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

Contents of /src/code/sap.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5