X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fbit-bash.lisp;h=cb54b817c63ec58903d5398460614acbd65a1560;hb=171fde84561e232b8af8c05b82dfe8a8f9e08340;hp=6afe33cce59a467d34ade6b5ae53c4a6eccde2ff;hpb=b08e81cd5a06fe5d792f0be1d1c2bf3409a4ae60;p=sbcl.git diff --git a/src/code/bit-bash.lisp b/src/code/bit-bash.lisp index 6afe33c..cb54b81 100644 --- a/src/code/bit-bash.lisp +++ b/src/code/bit-bash.lisp @@ -13,7 +13,8 @@ ;;;; 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 @@ -21,8 +22,8 @@ ;;; 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) @@ -39,32 +40,34 @@ ;;; 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)) @@ -87,18 +90,18 @@ #!-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)) ;;; the actual bashers and common uses of same @@ -117,15 +120,21 @@ (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 @@ -149,7 +158,7 @@ (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)) @@ -426,7 +435,7 @@ (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)