diff --git a/code/sap.lisp b/code/sap.lisp new file mode 100644 index 0000000000000000000000000000000000000000..ad9e321b22357a3f48553c1af60273f26d5df091 --- /dev/null +++ b/code/sap.lisp @@ -0,0 +1,212 @@ +;;; -*- Package: SYSTEM -*- +;;; +;;; ********************************************************************** +;;; 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/sap.lisp,v 1.1 1991/11/18 10:43:04 wlott Exp $") +;;; +;;; ********************************************************************** +;;; +;;; This file holds the support for System Area Pointers (saps). +;;; +(in-package "SYSTEM") + +(export '(system-area-pointer sap-ref-8 sap-ref-16 sap-ref-32 sap-ref-sap + signed-sap-ref-8 signed-sap-ref-16 signed-sap-ref-32 + sap+ sap- sap< sap<= sap= sap>= sap>)) + +(import '(%set-sap-ref-8 %set-sap-ref-16 %set-sap-ref-32 %set-sap-ref-sap + %set-sap-ref-single %set-sap-ref-double) + "C") + + +;;;; Primitive SAP operations. + +(defun sap< (x y) + "Return T iff the SAP X points to a smaller address then the SAP Y." + (declare (type system-area-pointer x y)) + (sap< x y)) + +(defun sap<= (x y) + "Return T iff the SAP X points to a smaller or the same address as + the SAP Y." + (declare (type system-area-pointer x y)) + (sap<= x y)) + +(defun sap= (x y) + "Return T iff the SAP X points to the same address as the SAP Y." + (declare (type system-area-pointer x y)) + (sap= x y)) + +(defun sap>= (x y) + "Return T iff the SAP X points to a larger or the same address as + the SAP Y." + (declare (type system-area-pointer x y)) + (sap>= x y)) + +(defun sap> (x y) + "Return T iff the SAP X points to a larger address then the SAP Y." + (declare (type system-area-pointer x y)) + (pointer> x y)) + +(defun sap+ (sap offset) + "Return a new sap OFFSET bytes from SAP." + (declare (type system-area-pointer sap) + (fixnum offset)) + (sap+ sap offset)) + +(defun sap- (sap1 sap2) + "Return the byte offset between SAP1 and SAP2." + (declare (type system-area-pointer sap1 sap2)) + (sap- sap1 sap2)) + +(defun sap-int (sap) + "Converts a System Area Pointer into an integer." + (declare (type system-area-pointer sap)) + (sap-int sap)) + +(defun int-sap (int) + "Converts an integer into a System Area Pointer." + (declare (type (unsigned-byte #.vm:word-bits) int)) + (int-sap int)) + +(defun sap-ref-8 (sap offset) + "Returns the 8-bit byte at OFFSET bytes from SAP." + (declare (type system-area-pointer sap) + (type index offset)) + (sap-ref-8 sap offset)) + +(defun sap-ref-16 (sap offset) + "Returns the 16-bit word at OFFSET half-words from SAP." + (declare (type system-area-pointer sap) + (type index offset)) + (sap-ref-16 sap offset)) + +(defun sap-ref-32 (sap offset) + "Returns the 32-bit dualword at OFFSET words from SAP." + (declare (type system-area-pointer sap) + (type index offset)) + (sap-ref-32 sap offset)) + +(defun sap-ref-sap (sap offset) + "Returns the 32-bit system-area-pointer at OFFSET words from SAP." + (declare (type system-area-pointer sap) + (type index offset)) + (sap-ref-sap sap offset)) + +(defun sap-ref-single (sap offset) + "Returns the 32-bit single-float at OFFSET words from SAP." + (declare (type system-area-pointer sap) + (type index offset)) + (sap-ref-single sap offset)) + +(defun sap-ref-double (sap offset) + "Returns the 64-bit double-float at OFFSET words from SAP." + (declare (type system-area-pointer sap) + (type index offset)) + (sap-ref-double sap offset)) + +(defun signed-sap-ref-8 (sap offset) + "Returns the signed 8-bit byte at Offset bytes from SAP." + (declare (type system-area-pointer sap) + (type index offset)) + (signed-sap-ref-8 sap offset)) + +(defun signed-sap-ref-16 (sap offset) + "Returns the signed 16-bit word at Offset words from SAP." + (declare (type system-area-pointer sap) + (type index offset)) + (signed-sap-ref-16 sap offset)) + +(defun signed-sap-ref-32 (sap offset) + "Returns the signed 32-bit dualword at Offset words from SAP." + (declare (type system-area-pointer sap) + (type index offset)) + (signed-sap-ref-32 sap offset)) + +(defun %set-sap-ref-8 (sap offset new-value) + (declare (type system-area-pointer sap) + (type index offset) + (type (or (signed-byte 8) (unsigned-byte 8)) new-value)) + (setf (sap-ref-8 sap offset) new-value)) + +(defun %set-sap-ref-16 (sap offset new-value) + (declare (type system-area-pointer sap) + (type index offset) + (type (or (signed-byte 16) (unsigned-byte 16)) new-value)) + (setf (sap-ref-16 sap offset) new-value)) + +(defun %set-sap-ref-32 (sap offset new-value) + (declare (type system-area-pointer sap) + (type index offset) + (type (or (signed-byte 32) (unsigned-byte 32)) new-value)) + (if (minusp new-value) + (truly-the (signed-byte 32) (setf (sap-ref-32 sap offset) new-value)) + (truly-the (unsigned-byte 32) (setf (sap-ref-32 sap offset) new-value)))) + +(defun %set-sap-ref-sap (sap offset new-value) + (declare (type system-area-pointer sap new-value) + (type index offset)) + (setf (sap-ref-sap sap offset) new-value)) + +(defun %set-sap-ref-single (sap offset new-value) + (declare (type system-area-pointer sap) + (type index offset) + (type single-float new-value)) + (setf (sap-ref-single sap offset) new-value)) + +(defun %set-sap-ref-double (sap offset new-value) + (declare (type system-area-pointer sap) + (type index offset) + (type double-float new-value)) + (setf (sap-ref-double sap offset) new-value)) + + + +;;;; System memory allocation. + +;;; ALLOCATE-SYSTEM-MEMORY -- public +;;; +;;; Allocate random memory from the system area. +;;; +(defun allocate-system-memory (bytes) + (declare (type index bytes)) + (gr-call* mach:vm_allocate *task-self* (int-sap 0) bytes t)) + +;;; REALLOCATE-SYSTEM-MEMORY -- public +;;; +;;; Either allocate more memory at the end of this block, or allocate a new +;;; block and move the old memory into it. +;;; +(defun reallocate-system-memory (old old-size new-size) + (declare (type system-area-pointer old) + (type index old-size new-size)) + ;; ### Got to work the page size into this somehow. The vm_allocate + ;; will fail much more often than it otherwise would 'cause if the old + ;; block stops in the middle of a page, we can't extend it. + (if (eql (mach:vm_allocate *task-self* + (sap+ old old-size) + (- new-size old-size) + nil) + mach:kern-success) + old + (let ((new (allocate-system-memory new-size))) + (declare (type system-area-pointer new)) + (system-area-copy old 0 new 0 (* old-size vm:byte-bits)) + (deallocate-system-memory old old-size) + new))) + +;;; DEALLOCATE-SYSTEM-MEMORY -- public +;;; +;;; Deallocate that memory. +;;; +(defun deallocate-system-memory (addr bytes) + (declare (type system-area-pointer addr) + (type index bytes)) + (gr-call* mach:vm_deallocate *task-self* addr bytes)) + +