\f
;;;; types
-(deftype bit-offset () '(integer 0 (#.sb!vm:n-word-bits)))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (deftype bit-offset () '(integer 0 (#.sb!vm:n-word-bits))))
;;;; support routines
;;; these, or DEFTRANSFORMs to convert them into something supported
;;; by the architecture.
(macrolet ((def (name &rest args)
- `(defun ,name ,args
- (,name ,@args))))
+ `(defun ,name ,args
+ (,name ,@args))))
(def word-logical-not x)
(def word-logical-and x y)
(def word-logical-or x y)
;;; at the "end" and removing bits from the "start". On big-endian
;;; machines this is a left-shift and on little-endian machines this
;;; is a right-shift.
-(defun shift-towards-start (number countoid)
- (declare (type sb!vm:word number) (fixnum countoid))
- (let ((count (ldb (byte (1- (integer-length sb!vm:n-word-bits)) 0) countoid)))
- (declare (type bit-offset count))
- (if (zerop count)
- number
- (ecase sb!c:*backend-byte-order*
- (:big-endian
- (ash (ldb (byte (- sb!vm:n-word-bits count) 0) number) count))
- (:little-endian
- (ash number (- count)))))))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun shift-towards-start (number countoid)
+ (declare (type sb!vm:word number) (fixnum countoid))
+ (let ((count (ldb (byte (1- (integer-length sb!vm:n-word-bits)) 0) countoid)))
+ (declare (type bit-offset count))
+ (if (zerop count)
+ number
+ (ecase sb!c:*backend-byte-order*
+ (:big-endian
+ (ash (ldb (byte (- sb!vm:n-word-bits count) 0) number) count))
+ (:little-endian
+ (ash number (- count))))))))
;;; Shift NUMBER by COUNT bits, adding zero bits at the "start" and
;;; removing bits from the "end". On big-endian machines this is a
;;; right-shift and on little-endian machines this is a left-shift.
-(defun shift-towards-end (number count)
- (declare (type sb!vm:word number) (fixnum count))
- (let ((count (ldb (byte (1- (integer-length sb!vm:n-word-bits)) 0) count)))
- (declare (type bit-offset count))
- (if (zerop count)
- number
- (ecase sb!c:*backend-byte-order*
- (:big-endian
- (ash number (- count)))
- (:little-endian
- (ash (ldb (byte (- sb!vm:n-word-bits count) 0) number) count))))))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun shift-towards-end (number count)
+ (declare (type sb!vm:word number) (fixnum count))
+ (let ((count (ldb (byte (1- (integer-length sb!vm:n-word-bits)) 0) count)))
+ (declare (type bit-offset count))
+ (if (zerop count)
+ number
+ (ecase sb!c:*backend-byte-order*
+ (:big-endian
+ (ash number (- count)))
+ (:little-endian
+ (ash (ldb (byte (- sb!vm:n-word-bits count) 0) number) count)))))))
#!-sb-fluid (declaim (inline start-mask end-mask))
#!-sb-fluid (declaim (inline word-sap-ref %set-word-sap-ref))
(defun word-sap-ref (sap offset)
(declare (type system-area-pointer sap)
- (type index offset)
- (values sb!vm:word)
- (optimize (speed 3) (safety 0) #-sb-xc-host (inhibit-warnings 3)))
- (sap-ref-word sap (the index (ash offset sb!vm:n-fixnum-tag-bits))))
+ (type index offset)
+ (values sb!vm:word)
+ (optimize (speed 3) (safety 0) #-sb-xc-host (inhibit-warnings 3)))
+ (sap-ref-word sap (the index (ash offset sb!vm:word-shift))))
(defun %set-word-sap-ref (sap offset value)
(declare (type system-area-pointer sap)
- (type index offset)
- (type sb!vm:word value)
- (values sb!vm:word)
- (optimize (speed 3) (safety 0) (inhibit-warnings 3)))
- (setf (sap-ref-word sap (the index (ash offset sb!vm:n-fixnum-tag-bits)))
- value))
+ (type index offset)
+ (type sb!vm:word value)
+ (values sb!vm:word)
+ (optimize (speed 3) (safety 0) (inhibit-warnings 3)))
+ (setf (sap-ref-word sap (the index (ash offset sb!vm:word-shift)))
+ value))
\f
;;; the actual bashers and common uses of same
(declare (type system-area-pointer sap)
(type index offset)
(values system-area-pointer index))
- (let ((address (sap-int sap)))
- (values (int-sap #!-alpha (word-logical-andc2 address
- sb!vm:fixnum-tag-mask)
- #!+alpha (ash (ash address -2) 2))
+ (let ((address (sap-int sap))
+ (word-mask (1- (ash 1 word-shift))))
+ (values (int-sap #!-alpha (word-logical-andc2 address word-mask)
+ ;; KLUDGE: WORD-LOGICAL-ANDC2 is defined in
+ ;; terms of n-word-bits. On all systems
+ ;; where n-word-bits is not equal to
+ ;; n-machine-word-bits we have to do this
+ ;; another way. At this time, these
+ ;; systems are alphas, though there was
+ ;; some talk about an x86-64 build option.
+ #!+alpha (ash (ash address (- word-shift)) word-shift))
(+ ,(ecase bitsize
- (1 '(* (logand address sb!vm:fixnum-tag-mask) n-byte-bits))
- (2 '(* (logand address sb!vm:fixnum-tag-mask) (/ n-byte-bits 2)))
- (4 '(* (logand address sb!vm:fixnum-tag-mask) (/ n-byte-bits 4)))
- ((8 16 32 64) '(logand address sb!vm:fixnum-tag-mask)))
+ ((1 2 4) `(* (logand address word-mask)
+ (/ n-byte-bits ,bitsize)))
+ ((8 16 32 64) '(logand address word-mask)))
offset)))))))
;;; We cheat a little bit by using TRULY-THE in the copying function to
(8 0)
(16 0)
(32 0)
- (64 0))))
+ (64 0))))
(offset `(integer 0 ,max-bytes))
(max-word-offset (ceiling max-bytes bytes-per-word))
(word-offset `(integer 0 ,max-word-offset))
(flet ((get-next-src ()
(setf prev next)
(setf next (funcall src-ref-fn src
- (setf src-word-offset (incf src-word-offset))))))
+ (incf src-word-offset)))))
(declare (inline get-next-src))
,@(unless (= bytes-per-word 1)
`((unless (zerop dst-byte-offset)