X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-sap.lisp;h=17f71910b4fa836b2541a097dc46f785f55acac6;hb=f41b718f89090d00e2625f103e29281061800729;hp=56f07891037b84df4932afa4cfae851a6bf87a8d;hpb=cea4896b2482b7b2b429c1631d774b4cfbc0efba;p=sbcl.git

diff --git a/src/code/target-sap.lisp b/src/code/target-sap.lisp
index 56f0789..17f7191 100644
--- a/src/code/target-sap.lisp
+++ b/src/code/target-sap.lisp
@@ -9,248 +9,241 @@
 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
 ;;;; files for more information.
 
-(in-package "SB!SYS")
-;;; FIXME: Shouldn't these be IN-PACKAGE SB!KERNEL instead? (They're
-;;; not dependent on the OS, only on the CPU architecture.)
-
-;;;; primitive SAP operations
+(in-package "SB!KERNEL")
 
+;;; Return T iff the SAP X points to a smaller address then the SAP Y.
 (defun sap< (x y)
-  #!+sb-doc
-  "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))
 
+;;; Return T iff the SAP X points to a smaller or the same address as
+;;; the SAP Y.
 (defun sap<= (x y)
-  #!+sb-doc
-  "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))
 
+;;; Return T iff the SAP X points to the same address as the SAP Y.
 (defun sap= (x y)
-  #!+sb-doc
-  "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))
 
+;;; Return T iff the SAP X points to a larger or the same address as
+;;; the SAP Y.
 (defun sap>= (x y)
-  #!+sb-doc
-  "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))
 
+;;; Return T iff the SAP X points to a larger address then the SAP Y.
 (defun sap> (x y)
-  #!+sb-doc
-  "Return T iff the SAP X points to a larger address then the SAP Y."
   (declare (type system-area-pointer x y))
   (sap> x y))
 
+;;; Return a new SAP, OFFSET bytes from SAP.
 (defun sap+ (sap offset)
-  #!+sb-doc
-  "Return a new sap OFFSET bytes from SAP."
   (declare (type system-area-pointer sap)
-	   (fixnum offset))
+           (type (signed-byte #.sb!vm:n-word-bits) offset))
   (sap+ sap offset))
 
+;;; Return the byte offset between SAP1 and SAP2.
 (defun sap- (sap1 sap2)
-  #!+sb-doc
-  "Return the byte offset between SAP1 and SAP2."
   (declare (type system-area-pointer sap1 sap2))
   (sap- sap1 sap2))
 
+;;; Convert SAP into an integer.
 (defun sap-int (sap)
-  #!+sb-doc
-  "Converts a System Area Pointer into an integer."
   (declare (type system-area-pointer sap))
   (sap-int sap))
 
+;;; Convert an integer into a SAP.
 (defun int-sap (int)
-  #!+sb-doc
-  "Converts an integer into a System Area Pointer."
-  (declare (type sap-int-type int))
+  (declare (type sap-int int))
   (int-sap int))
 
+;;; Return the 8-bit byte at OFFSET bytes from SAP.
 (defun sap-ref-8 (sap offset)
-  #!+sb-doc
-  "Returns the 8-bit byte at OFFSET bytes from SAP."
   (declare (type system-area-pointer sap)
-	   (fixnum offset))
+           (fixnum offset))
   (sap-ref-8 sap offset))
 
+(defun sap-ref-octets (sap offset count)
+  (declare (type system-area-pointer sap)
+           (fixnum offset count))
+  (let ((buffer (make-array count :element-type '(unsigned-byte 8))))
+    (dotimes (i count)
+      (setf (aref buffer i) (sap-ref-8 sap (+ offset i))))
+    buffer))
+
+;;; Return the 16-bit word at OFFSET bytes from SAP.
 (defun sap-ref-16 (sap offset)
-  #!+sb-doc
-  "Returns the 16-bit word at OFFSET bytes from SAP."
   (declare (type system-area-pointer sap)
-	   (fixnum offset))
+           (fixnum offset))
   (sap-ref-16 sap offset))
 
+;;; Returns the 32-bit dualword at OFFSET bytes from SAP.
 (defun sap-ref-32 (sap offset)
-  #!+sb-doc
-  "Returns the 32-bit dualword at OFFSET bytes from SAP."
   (declare (type system-area-pointer sap)
-	   (fixnum offset))
+           (fixnum offset))
   (sap-ref-32 sap offset))
 
-#!+alpha
+;;; Return the 64-bit quadword at OFFSET bytes from SAP.
 (defun sap-ref-64 (sap offset)
-  #!+sb-doc
-  "Returns the 64-bit quadword at OFFSET bytes from SAP."
   (declare (type system-area-pointer sap)
-	   (fixnum offset))
+           (fixnum offset))
   (sap-ref-64 sap offset))
 
+;;; Return the unsigned word of natural size OFFSET bytes from SAP.
+(defun sap-ref-word (sap offset)
+  (declare (type system-area-pointer sap)
+           (fixnum offset))
+  (sap-ref-word sap offset))
+
+;;; Return the 32-bit SAP at OFFSET bytes from SAP.
 (defun sap-ref-sap (sap offset)
-  #!+sb-doc
-  "Returns the 32-bit system-area-pointer at OFFSET bytes from SAP."
   (declare (type system-area-pointer sap)
-	   (fixnum offset))
+           (fixnum offset))
   (sap-ref-sap sap offset))
 
+;; Return the LISPOBJ at OFFSET bytes from SAP.
+(defun sap-ref-lispobj (sap offset)
+  (declare (type system-area-pointer sap)
+           (fixnum offset))
+  (sap-ref-lispobj sap offset))
+
+;;; Return the 32-bit SINGLE-FLOAT at OFFSET bytes from SAP.
 (defun sap-ref-single (sap offset)
-  #!+sb-doc
-  "Returns the 32-bit single-float at OFFSET bytes from SAP."
   (declare (type system-area-pointer sap)
-	   (fixnum offset))
+           (fixnum offset))
   (sap-ref-single sap offset))
 
+;;; Return the 64-bit DOUBLE-FLOAT at OFFSET bytes from SAP.
 (defun sap-ref-double (sap offset)
-  #!+sb-doc
-  "Returns the 64-bit double-float at OFFSET bytes from SAP."
   (declare (type system-area-pointer sap)
-	   (fixnum offset))
+           (fixnum offset))
   (sap-ref-double sap offset))
 
+;;; Return the LONG-FLOAT at OFFSET bytes from SAP.
 #!+(or x86 long-float)
 (defun sap-ref-long (sap offset)
-  #!+sb-doc
-  "Returns the long-float at OFFSET bytes from SAP."
   (declare (type system-area-pointer sap)
-	   (fixnum offset))
+           (fixnum offset))
   (sap-ref-long sap offset))
 
+;;; Return the signed 8-bit byte at OFFSET bytes from SAP.
 (defun signed-sap-ref-8 (sap offset)
-  #!+sb-doc
-  "Returns the signed 8-bit byte at OFFSET bytes from SAP."
   (declare (type system-area-pointer sap)
-	   (fixnum offset))
+           (fixnum offset))
   (signed-sap-ref-8 sap offset))
 
+;;; Return the signed 16-bit word at OFFSET bytes from SAP.
 (defun signed-sap-ref-16 (sap offset)
-  #!+sb-doc
-  "Returns the signed 16-bit word at OFFSET bytes from SAP."
   (declare (type system-area-pointer sap)
-	   (fixnum offset))
+           (fixnum offset))
   (signed-sap-ref-16 sap offset))
 
+;;; Return the signed 32-bit dualword at OFFSET bytes from SAP.
 (defun signed-sap-ref-32 (sap offset)
-  #!+sb-doc
-  "Returns the signed 32-bit dualword at OFFSET bytes from SAP."
   (declare (type system-area-pointer sap)
-	   (fixnum offset))
+           (fixnum offset))
   (signed-sap-ref-32 sap offset))
 
-#!+alpha
+;;; Return the signed 64-bit quadword at OFFSET bytes from SAP.
 (defun signed-sap-ref-64 (sap offset)
-  #!+sb-doc
-  "Returns the signed 64-bit quadword at OFFSET bytes from SAP."
   (declare (type system-area-pointer sap)
-	   (fixnum offset))
+           (fixnum offset))
   (signed-sap-ref-64 sap offset))
 
+;;; Return the signed word of natural size OFFSET bytes from SAP.
+(defun signed-sap-ref-word (sap offset)
+  (declare (type system-area-pointer sap)
+           (fixnum offset))
+  (signed-sap-ref-word sap offset))
+
 (defun %set-sap-ref-8 (sap offset new-value)
   (declare (type system-area-pointer sap)
-	   (fixnum offset)
-	   (type (unsigned-byte 8) new-value))
+           (fixnum offset)
+           (type (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)
-	   (fixnum offset)
-	   (type (unsigned-byte 16) new-value))
+           (fixnum offset)
+           (type (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)
-	   (fixnum offset)
-	   (type (unsigned-byte 32) new-value))
+           (fixnum offset)
+           (type (unsigned-byte 32) new-value))
   (setf (sap-ref-32 sap offset) new-value))
 
-#!+alpha
 (defun %set-sap-ref-64 (sap offset new-value)
   (declare (type system-area-pointer sap)
-	   (fixnum offset)
-	   (type (unsigned-byte 64) new-value))
+           (fixnum offset)
+           (type (unsigned-byte 64) new-value))
   (setf (sap-ref-64 sap offset) new-value))
 
+(defun %set-sap-ref-word (sap offset new-value)
+  (declare (type system-area-pointer sap)
+           (fixnum offset)
+           (type (unsigned-byte #.sb!vm:n-machine-word-bits) new-value))
+  (setf (sap-ref-word sap offset) new-value))
+
 (defun %set-signed-sap-ref-8 (sap offset new-value)
   (declare (type system-area-pointer sap)
-	   (fixnum offset)
-	   (type (signed-byte 8) new-value))
+           (fixnum offset)
+           (type (signed-byte 8) new-value))
   (setf (signed-sap-ref-8 sap offset) new-value))
 
 (defun %set-signed-sap-ref-16 (sap offset new-value)
   (declare (type system-area-pointer sap)
-	   (fixnum offset)
-	   (type (signed-byte 16) new-value))
+           (fixnum offset)
+           (type (signed-byte 16) new-value))
   (setf (signed-sap-ref-16 sap offset) new-value))
 
 (defun %set-signed-sap-ref-32 (sap offset new-value)
   (declare (type system-area-pointer sap)
-	   (fixnum offset)
-	   (type (signed-byte 32) new-value))
+           (fixnum offset)
+           (type (signed-byte 32) new-value))
   (setf (signed-sap-ref-32 sap offset) new-value))
 
-#!+alpha
 (defun %set-signed-sap-ref-64 (sap offset new-value)
   (declare (type system-area-pointer sap)
-	   (fixnum offset)
-	   (type (signed-byte 64) new-value))
+           (fixnum offset)
+           (type (signed-byte 64) new-value))
   (setf (signed-sap-ref-64 sap offset) new-value))
 
+(defun %set-signed-sap-ref-word (sap offset new-value)
+  (declare (type system-area-pointer sap)
+           (fixnum offset)
+           (type (signed-byte #.sb!vm:n-machine-word-bits) new-value))
+  (setf (signed-sap-ref-word sap offset) new-value))
+
 (defun %set-sap-ref-sap (sap offset new-value)
   (declare (type system-area-pointer sap new-value)
-	   (fixnum offset))
+           (fixnum offset))
   (setf (sap-ref-sap sap offset) new-value))
 
+(defun %set-sap-ref-lispobj (sap offset new-value)
+  (declare (type system-area-pointer sap)
+           (fixnum offset)
+           (t new-value))
+  (setf (sap-ref-lispobj sap offset) new-value))
+
 (defun %set-sap-ref-single (sap offset new-value)
   (declare (type system-area-pointer sap)
-	   (fixnum offset)
-	   (type single-float new-value))
+           (fixnum 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)
-	   (fixnum offset)
-	   (type double-float new-value))
+           (fixnum offset)
+           (type double-float new-value))
   (setf (sap-ref-double sap offset) new-value))
 
 #!+long-float
 (defun %set-sap-ref-long (sap offset new-value)
   (declare (type system-area-pointer sap)
-	   (fixnum offset)
-	   (type long-float new-value))
+           (fixnum offset)
+           (type long-float new-value))
   (setf (sap-ref-long sap offset) new-value))
-
-;;;; system memory allocation
-
-(sb!alien:def-alien-routine ("os_allocate" allocate-system-memory)
-			    system-area-pointer
-  (bytes sb!c-call:unsigned-long))
-
-(sb!alien:def-alien-routine ("os_allocate_at" allocate-system-memory-at)
-			    system-area-pointer
-  (address system-area-pointer)
-  (bytes sb!c-call:unsigned-long))
-
-(sb!alien:def-alien-routine ("os_reallocate" reallocate-system-memory)
-			    system-area-pointer
-  (old system-area-pointer)
-  (old-size sb!c-call:unsigned-long)
-  (new-size sb!c-call:unsigned-long))
-
-(sb!alien:def-alien-routine ("os_deallocate" deallocate-system-memory)
-			    sb!c-call:void
-  (addr system-area-pointer)
-  (bytes sb!c-call:unsigned-long))