src/code/bit-bash.lisp

   1 ;;;; functions to implement bitblt-ish operations
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 (in-package "SB!VM")
  13 \f
  14 ;;;; types
  15
  16 (deftype bit-offset () '(integer 0 (#.sb!vm:n-word-bits)))
  17
  18 ;;;; support routines
  19
  20 ;;; A particular implementation must offer either VOPs to translate
  21 ;;; these, or DEFTRANSFORMs to convert them into something supported
  22 ;;; by the architecture.
  23 (macrolet ((def (name &rest args)
  24              `(defun ,name ,args
  25                 (,name ,@args))))
  26   (def word-logical-not x)
  27   (def word-logical-and x y)
  28   (def word-logical-or x y)
  29   (def word-logical-xor x y)
  30   (def word-logical-nor x y)
  31   (def word-logical-eqv x y)
  32   (def word-logical-nand x y)
  33   (def word-logical-andc1 x y)
  34   (def word-logical-andc2 x y)
  35   (def word-logical-orc1 x y)
  36   (def word-logical-orc2 x y))
  37
  38 ;;; Shift NUMBER by the low-order bits of COUNTOID, adding zero bits
  39 ;;; at the "end" and removing bits from the "start". On big-endian
  40 ;;; machines this is a left-shift and on little-endian machines this
  41 ;;; is a right-shift.
  42 (defun shift-towards-start (number countoid)
  43   (declare (type sb!vm:word number) (fixnum countoid))
  44   (let ((count (ldb (byte (1- (integer-length sb!vm:n-word-bits)) 0) countoid)))
  45     (declare (type bit-offset count))
  46     (if (zerop count)
  47         number
  48         (ecase sb!c:*backend-byte-order*
  49           (:big-endian
  50            (ash (ldb (byte (- sb!vm:n-word-bits count) 0) number) count))
  51           (:little-endian
  52            (ash number (- count)))))))
  53
  54 ;;; Shift NUMBER by COUNT bits, adding zero bits at the "start" and
  55 ;;; removing bits from the "end". On big-endian machines this is a
  56 ;;; right-shift and on little-endian machines this is a left-shift.
  57 (defun shift-towards-end (number count)
  58   (declare (type sb!vm:word number) (fixnum count))
  59   (let ((count (ldb (byte (1- (integer-length sb!vm:n-word-bits)) 0) count)))
  60     (declare (type bit-offset count))
  61     (if (zerop count)
  62         number
  63         (ecase sb!c:*backend-byte-order*
  64           (:big-endian
  65            (ash number (- count)))
  66           (:little-endian
  67            (ash (ldb (byte (- sb!vm:n-word-bits count) 0) number) count))))))
  68
  69 #!-sb-fluid (declaim (inline start-mask end-mask))
  70
  71 ;;; Produce a mask that contains 1's for the COUNT "start" bits and
  72 ;;; 0's for the remaining "end" bits. Only the lower 5 bits of COUNT
  73 ;;; are significant (KLUDGE: because of hardwired implicit dependence
  74 ;;; on 32-bit word size -- WHN 2001-03-19).
  75 (defun start-mask (count)
  76   (declare (fixnum count))
  77   (shift-towards-start (1- (ash 1 sb!vm:n-word-bits)) (- count)))
  78
  79 ;;; Produce a mask that contains 1's for the COUNT "end" bits and 0's
  80 ;;; for the remaining "start" bits. Only the lower 5 bits of COUNT are
  81 ;;; significant (KLUDGE: because of hardwired implicit dependence on
  82 ;;; 32-bit word size -- WHN 2001-03-19).
  83 (defun end-mask (count)
  84   (declare (fixnum count))
  85   (shift-towards-end (1- (ash 1 sb!vm:n-word-bits)) (- count)))
  86
  87 #!-sb-fluid (declaim (inline word-sap-ref %set-word-sap-ref))
  88 (defun word-sap-ref (sap offset)
  89   (declare (type system-area-pointer sap)
  90            (type index offset)
  91            (values sb!vm:word)
  92            (optimize (speed 3) (safety 0) #-sb-xc-host (inhibit-warnings 3)))
  93   (sap-ref-word sap (the index (ash offset sb!vm:n-fixnum-tag-bits))))
  94 (defun %set-word-sap-ref (sap offset value)
  95   (declare (type system-area-pointer sap)
  96            (type index offset)
  97            (type sb!vm:word value)
  98            (values sb!vm:word)
  99            (optimize (speed 3) (safety 0) (inhibit-warnings 3)))
 100   (setf (sap-ref-word sap (the index (ash offset sb!vm:n-fixnum-tag-bits)))
 101         value))
 102
 103 \f
 104 ;;; the actual bashers and common uses of same
 105
 106 ;;; This is a little ugly.  Fixing bug 188 would bring the ability to
 107 ;;; wrap a MACROLET or something similar around this whole thing would
 108 ;;; make things significantly less ugly.  --njf, 2005-02-23
 109 (eval-when (:compile-toplevel :load-toplevel :execute)
 110
 111 ;;; Align the SAP to a word boundary, and update the offset accordingly.
 112 (defmacro !define-sap-fixer (bitsize)
 113   (let ((name (intern (format nil "FIX-SAP-AND-OFFSET-UB~D" bitsize))))
 114     `(progn
 115       (declaim (inline ,name))
 116       (defun ,name (sap offset)
 117         (declare (type system-area-pointer sap)
 118                  (type index offset)
 119                  (values system-area-pointer index))
 120         (let ((address (sap-int sap)))
 121           (values (int-sap #!-alpha (word-logical-andc2 address
 122                                                         sb!vm:fixnum-tag-mask)
 123                            #!+alpha (ash (ash address -2) 2))
 124                   (+ ,(ecase bitsize
 125                        (1 '(* (logand address sb!vm:fixnum-tag-mask) n-byte-bits))
 126                        (2 '(* (logand address sb!vm:fixnum-tag-mask) (/ n-byte-bits 2)))
 127                        (4 '(* (logand address sb!vm:fixnum-tag-mask) (/ n-byte-bits 4)))
 128                        ((8 16 32 64) '(logand address sb!vm:fixnum-tag-mask)))
 129                      offset)))))))
 130
 131 ;;; We cheat a little bit by using TRULY-THE in the copying function to
 132 ;;; force the compiler to generate good code in the (= BITSIZE
 133 ;;; SB!VM:N-WORD-BITS) case.  We don't use TRULY-THE in the other cases
 134 ;;; to give the compiler freedom to generate better code.
 135 (defmacro !define-byte-bashers (bitsize)
 136   (let* ((bytes-per-word (/ n-word-bits bitsize))
 137          (byte-offset `(integer 0 (,bytes-per-word)))
 138          (byte-count `(integer 1 (,bytes-per-word)))
 139          (max-bytes (ash sb!xc:most-positive-fixnum
 140                          ;; FIXME: this reflects code contained in the
 141                          ;; original bit-bash.lisp, but seems very
 142                          ;; nonsensical.  Why shouldn't we be able to
 143                          ;; handle M-P-FIXNUM bits?  And if we can't,
 144                          ;; are these other shift amounts bogus, too?
 145                          (ecase bitsize
 146                            (1 -2)
 147                            (2 -1)
 148                            (4  0)
 149                            (8  0)
 150                            (16 0)
 151                            (32 0)
 152                            (64 0))))
 153          (offset `(integer 0 ,max-bytes))
 154          (max-word-offset (ceiling max-bytes bytes-per-word))
 155          (word-offset `(integer 0 ,max-word-offset))
 156          (fix-sap-and-offset-name (intern (format nil "FIX-SAP-AND-OFFSET-UB~D" bitsize)))
 157          (constant-bash-name (intern (format nil "CONSTANT-UB~D-BASH" bitsize) (find-package "SB!KERNEL")))
 158          (array-fill-name (intern (format nil "UB~D-BASH-FILL" bitsize) (find-package "SB!KERNEL")))
 159          (system-area-fill-name (intern (format nil "SYSTEM-AREA-UB~D-FILL" bitsize) (find-package "SB!KERNEL")))
 160          (unary-bash-name (intern (format nil "UNARY-UB~D-BASH" bitsize) (find-package "SB!KERNEL")))
 161          (array-copy-name (intern (format nil "UB~D-BASH-COPY" bitsize) (find-package "SB!KERNEL")))
 162          (system-area-copy-name (intern (format nil "SYSTEM-AREA-UB~D-COPY" bitsize) (find-package "SB!KERNEL")))
 163          (array-copy-to-system-area-name
 164           (intern (format nil "COPY-UB~D-TO-SYSTEM-AREA" bitsize) (find-package "SB!KERNEL")))
 165          (system-area-copy-to-array-name
 166           (intern (format nil "COPY-UB~D-FROM-SYSTEM-AREA" bitsize)
 167                   (find-package "SB!KERNEL"))))
 168     `(progn
 169       (declaim (inline ,constant-bash-name ,unary-bash-name))
 170       ;; Fill DST with VALUE starting at DST-OFFSET and continuing
 171       ;; for LENGTH bytes (however bytes are defined).
 172       (defun ,constant-bash-name (dst dst-offset length value
 173                                       dst-ref-fn dst-set-fn)
 174         (declare (type word value) (type index dst-offset length))
 175         (declare (ignorable dst-ref-fn))
 176         (multiple-value-bind (dst-word-offset dst-byte-offset)
 177             (floor dst-offset ,bytes-per-word)
 178           (declare (type ,word-offset dst-word-offset)
 179                    (type ,byte-offset dst-byte-offset))
 180           (multiple-value-bind (n-words final-bytes)
 181               (floor (+ dst-byte-offset length) ,bytes-per-word)
 182             (declare (type ,word-offset n-words)
 183                      (type ,byte-offset final-bytes))
 184             (if (zerop n-words)
 185                 ,(unless (= bytes-per-word 1)
 186                   `(unless (zerop length)
 187                     (locally (declare (type ,byte-count length))
 188                       (funcall dst-set-fn dst dst-word-offset
 189                                (if (= length ,bytes-per-word)
 190                                    value
 191                                    (let ((mask (shift-towards-end
 192                                                 (start-mask (* length ,bitsize))
 193                                                 (* dst-byte-offset ,bitsize))))
 194                                      (word-logical-or (word-logical-and value mask)
 195                                                       (word-logical-andc2 (funcall dst-ref-fn dst dst-word-offset)
 196                                                                           mask))))))))
 197                 (let ((interior (floor (- length final-bytes) ,bytes-per-word)))
 198                   ,@(unless (= bytes-per-word 1)
 199                      `((unless (zerop dst-byte-offset)
 200                          (let ((mask (end-mask (* (- dst-byte-offset) ,bitsize))))
 201                            (funcall dst-set-fn dst dst-word-offset
 202                                     (word-logical-or (word-logical-and value mask)
 203                                                      (word-logical-andc2 (funcall dst-ref-fn dst dst-word-offset)
 204                                                                          mask))))
 205                          (incf dst-word-offset))))
 206                   (let ((end (+ dst-word-offset interior)))
 207                     (declare (type ,word-offset end))
 208                     (do ()
 209                         ((>= dst-word-offset end))
 210                       (funcall dst-set-fn dst dst-word-offset value)
 211                       (incf dst-word-offset)))
 212                   #+nil
 213                   (dotimes (i interior)
 214                     (funcall dst-set-fn dst dst-word-offset value)
 215                     (incf dst-word-offset))
 216                   ,@(unless (= bytes-per-word 1)
 217                      `((unless (zerop final-bytes)
 218                          (let ((mask (start-mask (* final-bytes ,bitsize))))
 219                            (funcall dst-set-fn dst dst-word-offset
 220                                     (word-logical-or (word-logical-and value mask)
 221                                                      (word-logical-andc2 (funcall dst-ref-fn dst dst-word-offset)
 222                                                                          mask)))))))))))
 223         (values))
 224
 225       ;; common uses for constant-byte-bashing
 226       (defun ,array-fill-name (value dst dst-offset length)
 227         (declare (type word value) (type ,offset dst-offset length))
 228         (declare (optimize (speed 3) (safety 1)))
 229         (,constant-bash-name dst dst-offset length value
 230                              #'%vector-raw-bits #'%set-vector-raw-bits))
 231       (defun ,system-area-fill-name (value dst dst-offset length)
 232         (declare (type word value) (type ,offset dst-offset length))
 233         (declare (optimize (speed 3) (safety 1)))
 234         (multiple-value-bind (dst dst-offset) (,fix-sap-and-offset-name dst dst-offset)
 235           (,constant-bash-name dst dst-offset length value
 236                                #'word-sap-ref #'%set-word-sap-ref)))
 237
 238          ;; unary byte bashing (copying)
 239          (defun ,unary-bash-name (src src-offset dst dst-offset length
 240                                       dst-ref-fn dst-set-fn src-ref-fn)
 241            (declare (type index src-offset dst-offset length)
 242                     (type function dst-ref-fn dst-set-fn src-ref-fn)
 243                     (ignorable dst-ref-fn))
 244            (multiple-value-bind (dst-word-offset dst-byte-offset)
 245                (floor dst-offset ,bytes-per-word)
 246              (declare (type ,word-offset dst-word-offset)
 247                       (type ,byte-offset dst-byte-offset))
 248              (multiple-value-bind (src-word-offset src-byte-offset)
 249                  (floor src-offset ,bytes-per-word)
 250                (declare (type ,word-offset src-word-offset)
 251                         (type ,byte-offset src-byte-offset))
 252                (cond
 253                  ((<= (+ dst-byte-offset length) ,bytes-per-word)
 254                   ;; We are only writing one word, so it doesn't matter what
 255                   ;; order we do it in.  But we might be reading from
 256                   ;; multiple words, so take care.
 257                   (cond
 258                     ((zerop length)
 259                      ;; We're not writing anything.  This is really easy.
 260                      )
 261                     ((= length ,bytes-per-word)
 262                      ;; DST-BYTE-OFFSET must be equal to zero, or we would be
 263                      ;; writing multiple words.  If SRC-BYTE-OFFSET is also zero,
 264                      ;; the we just transfer the single word.  Otherwise we have
 265                      ;; to extract bytes from two source words.
 266                      (funcall dst-set-fn dst dst-word-offset
 267                              (cond
 268                                ((zerop src-byte-offset)
 269                                 (funcall src-ref-fn src src-word-offset))
 270                                ,@(unless (= bytes-per-word 1)
 271                                   `((t (word-logical-or (shift-towards-start
 272                                                          (funcall src-ref-fn src src-word-offset)
 273                                                          (* src-byte-offset ,bitsize))
 274                                         (shift-towards-end
 275                                           (funcall src-ref-fn src (1+ src-word-offset))
 276                                           (* (- src-byte-offset) ,bitsize)))))))))
 277                     ,@(unless (= bytes-per-word 1)
 278                        `((t
 279                           ;; We are only writing some portion of the destination word.
 280                           ;; We still don't know whether we need one or two source words.
 281                           (locally (declare (type ,byte-count length))
 282                             (let ((mask (shift-towards-end (start-mask (* length ,bitsize))
 283                                                            (* dst-byte-offset ,bitsize)))
 284                                   (orig (funcall dst-ref-fn dst dst-word-offset))
 285                                   (value (if (> src-byte-offset dst-byte-offset)
 286                                              ;; The source starts further
 287                                              ;; into the word than does the
 288                                              ;; destination, so the source
 289                                              ;; could extend into the next
 290                                              ;; word.  If it does, we have
 291                                              ;; to merge the two words, and
 292                                              ;; it not, we can just shift
 293                                              ;; the first word.
 294                                              (let ((src-byte-shift (- src-byte-offset
 295                                                                       dst-byte-offset)))
 296                                                (if (> (+ src-byte-offset length) ,bytes-per-word)
 297                                                    (word-logical-or
 298                                                     (shift-towards-start
 299                                                      (funcall src-ref-fn src src-word-offset)
 300                                                      (* src-byte-shift ,bitsize))
 301                                                     (shift-towards-end
 302                                                      (funcall src-ref-fn src (1+ src-word-offset))
 303                                                      (* (- src-byte-shift) ,bitsize)))
 304                                                    (shift-towards-start (funcall src-ref-fn src src-word-offset)
 305                                                                         (* src-byte-shift ,bitsize))))
 306                                              ;; The destination starts further
 307                                              ;; into the word than does the
 308                                              ;; source, so we know the source
 309                                              ;; cannot extend into a second
 310                                              ;; word (or else the destination
 311                                              ;; would too, and we wouldn't be
 312                                              ;; in this branch).
 313                                              (shift-towards-end
 314                                               (funcall src-ref-fn src src-word-offset)
 315                                               (* (- dst-byte-offset src-byte-offset) ,bitsize)))))
 316                               (declare (type word mask orig value))
 317                               (funcall dst-set-fn dst dst-word-offset
 318                                        (word-logical-or (word-logical-and value mask)
 319                                                         (word-logical-andc2 orig mask))))))))))
 320                  ((= src-byte-offset dst-byte-offset)
 321                   ;; The source and destination are aligned, so shifting
 322                   ;; is unnecessary.  But we have to pick the direction
 323                   ;; of the copy in case the source and destination are
 324                   ;; really the same object.
 325                   (multiple-value-bind (words final-bytes)
 326                       (floor (+ dst-byte-offset length) ,bytes-per-word)
 327                     (declare (type ,word-offset words)
 328                              (type ,byte-offset final-bytes))
 329                     (let ((interior (floor (- length final-bytes) ,bytes-per-word)))
 330                       (declare (type ,word-offset interior))
 331                       (cond
 332                         ((<= dst-offset src-offset)
 333                          ;; We need to loop from left to right.
 334                          ,@(unless (= bytes-per-word 1)
 335                             `((unless (zerop dst-byte-offset)
 336                                 ;; We are only writing part of the first word, so mask
 337                                 ;; off the bytes we want to preserve.
 338                                 (let ((mask (end-mask (* (- dst-byte-offset) ,bitsize)))
 339                                       (orig (funcall dst-ref-fn dst dst-word-offset))
 340                                       (value (funcall src-ref-fn src src-word-offset)))
 341                                   (declare (type word mask orig value))
 342                                   (funcall dst-set-fn dst dst-word-offset
 343                                            (word-logical-or (word-logical-and value mask)
 344                                                             (word-logical-andc2 orig mask))))
 345                                 (incf src-word-offset)
 346                                 (incf dst-word-offset))))
 347                          ;; Copy the interior words.
 348                          (let ((end ,(if (= bytes-per-word 1)
 349                                          `(truly-the ,word-offset
 350                                            (+ dst-word-offset interior))
 351                                          `(+ dst-word-offset interior))))
 352                            (declare (type ,word-offset end))
 353                            (do ()
 354                                ((>= dst-word-offset end))
 355                              (funcall dst-set-fn dst dst-word-offset
 356                                       (funcall src-ref-fn src src-word-offset))
 357                              ,(if (= bytes-per-word 1)
 358                                   `(setf src-word-offset (truly-the ,word-offset (+ src-word-offset 1)))
 359                                   `(incf src-word-offset))
 360                              (incf dst-word-offset)))
 361                          ,@(unless (= bytes-per-word 1)
 362                             `((unless (zerop final-bytes)
 363                                 ;; We are only writing part of the last word.
 364                                 (let ((mask (start-mask (* final-bytes ,bitsize)))
 365                                       (orig (funcall dst-ref-fn dst dst-word-offset))
 366                                       (value (funcall src-ref-fn src src-word-offset)))
 367                                   (declare (type word mask orig value))
 368                                   (funcall dst-set-fn dst dst-word-offset
 369                                            (word-logical-or (word-logical-and value mask)
 370                                                             (word-logical-andc2 orig mask))))))))
 371                         (t
 372                          ;; We need to loop from right to left.
 373                          ,(if (= bytes-per-word 1)
 374                               `(setf dst-word-offset (truly-the ,word-offset
 375                                                       (+ dst-word-offset words)))
 376                               `(incf dst-word-offset words))
 377                          ,(if (= bytes-per-word 1)
 378                               `(setf src-word-offset (truly-the ,word-offset
 379                                                       (+ src-word-offset words)))
 380                               `(incf src-word-offset words))
 381                          ,@(unless (= bytes-per-word 1)
 382                             `((unless (zerop final-bytes)
 383                                 (let ((mask (start-mask (* final-bytes ,bitsize)))
 384                                       (orig (funcall dst-ref-fn dst dst-word-offset))
 385                                       (value (funcall src-ref-fn src src-word-offset)))
 386                                   (declare (type word mask orig value))
 387                                   (funcall dst-set-fn dst dst-word-offset
 388                                            (word-logical-or (word-logical-and value mask)
 389                                                             (word-logical-andc2 orig mask)))))))
 390                          (let ((end (- dst-word-offset interior)))
 391                            (do ()
 392                                ((<= dst-word-offset end))
 393                              (decf src-word-offset)
 394                              (decf dst-word-offset)
 395                              (funcall dst-set-fn dst dst-word-offset
 396                                       (funcall src-ref-fn src src-word-offset))))
 397                          ,@(unless (= bytes-per-word 1)
 398                             `((unless (zerop dst-byte-offset)
 399                                 ;; We are only writing part of the last word.
 400                                 (decf src-word-offset)
 401                                 (decf dst-word-offset)
 402                                 (let ((mask (end-mask (* (- dst-byte-offset) ,bitsize)))
 403                                       (orig (funcall dst-ref-fn dst dst-word-offset))
 404                                       (value (funcall src-ref-fn src src-word-offset)))
 405                                   (declare (type word mask orig value))
 406                                   (funcall dst-set-fn dst dst-word-offset
 407                                            (word-logical-or (word-logical-and value mask)
 408                                                             (word-logical-andc2 orig mask))))))))))))
 409                  (t
 410                   ;; Source and destination are not aligned.
 411                   (multiple-value-bind (words final-bytes)
 412                       (floor (+ dst-byte-offset length) ,bytes-per-word)
 413                     (declare (type ,word-offset words)
 414                              (type ,byte-offset final-bytes))
 415                     (let ((src-shift (mod (- src-byte-offset dst-byte-offset)
 416                                           ,bytes-per-word))
 417                           (interior (floor (- length final-bytes) ,bytes-per-word)))
 418                       (declare (type ,word-offset interior)
 419                                (type ,byte-offset src-shift))
 420                       (cond
 421                         ((<= dst-offset src-offset)
 422                          ;; We need to loop from left to right.
 423                          (let ((prev 0)
 424                                (next (funcall src-ref-fn src src-word-offset)))
 425                            (declare (type word prev next))
 426                            (flet ((get-next-src ()
 427                                     (setf prev next)
 428                                     (setf next (funcall src-ref-fn src
 429                                                         (setf src-word-offset (incf src-word-offset))))))
 430                              (declare (inline get-next-src))
 431                              ,@(unless (= bytes-per-word 1)
 432                                 `((unless (zerop dst-byte-offset)
 433                                     (when (> src-byte-offset dst-byte-offset)
 434                                       (get-next-src))
 435                                     (let ((mask (end-mask (* (- dst-byte-offset) ,bitsize)))
 436                                           (orig (funcall dst-ref-fn dst dst-word-offset))
 437                                           (value (word-logical-or (shift-towards-start prev (* src-shift ,bitsize))
 438                                                                   (shift-towards-end next (* (- src-shift) ,bitsize)))))
 439                                       (declare (type word mask orig value))
 440                                       (funcall dst-set-fn dst dst-word-offset
 441                                                (word-logical-or (word-logical-and value mask)
 442                                                                 (word-logical-andc2 orig mask))))
 443                                     (incf dst-word-offset))))
 444                              (let ((end (+ dst-word-offset interior)))
 445                                (declare (type ,word-offset end))
 446                                (do ()
 447                                    ((>= dst-word-offset end))
 448                                  (get-next-src)
 449                                  (let ((value (word-logical-or
 450                                                (shift-towards-end next (* (- src-shift) ,bitsize))
 451                                                (shift-towards-start prev (* src-shift ,bitsize)))))
 452                                    (declare (type word value))
 453                                    (funcall dst-set-fn dst dst-word-offset value)
 454                                    (incf dst-word-offset))))
 455                              ,@(unless (= bytes-per-word 1)
 456                                 `((unless (zerop final-bytes)
 457                                     (let ((value
 458                                            (if (> (+ final-bytes src-shift) ,bytes-per-word)
 459                                                (progn
 460                                                  (get-next-src)
 461                                                  (word-logical-or
 462                                                   (shift-towards-end next (* (- src-shift) ,bitsize))
 463                                                   (shift-towards-start prev (* src-shift ,bitsize))))
 464                                                (shift-towards-start next (* src-shift ,bitsize))))
 465                                           (mask (start-mask (* final-bytes ,bitsize)))
 466                                           (orig (funcall dst-ref-fn dst dst-word-offset)))
 467                                       (declare (type word mask orig value))
 468                                       (funcall dst-set-fn dst dst-word-offset
 469                                                (word-logical-or (word-logical-and value mask)
 470                                                                 (word-logical-andc2 orig mask))))))))))
 471                         (t
 472                          ;; We need to loop from right to left.
 473                          (incf dst-word-offset words)
 474                          (incf src-word-offset (1- (ceiling (+ src-byte-offset length) ,bytes-per-word)))
 475                          (let ((next 0)
 476                                (prev (funcall src-ref-fn src src-word-offset)))
 477                            (declare (type word prev next))
 478                            (flet ((get-next-src ()
 479                                     (setf next prev)
 480                                     (setf prev (funcall src-ref-fn src (decf src-word-offset)))))
 481                              (declare (inline get-next-src))
 482                              ,@(unless (= bytes-per-word 1)
 483                                 `((unless (zerop final-bytes)
 484                                     (when (> final-bytes (- ,bytes-per-word src-shift))
 485                                       (get-next-src))
 486                                     (let ((value (word-logical-or
 487                                                   (shift-towards-end next (* (- src-shift) ,bitsize))
 488                                                   (shift-towards-start prev (* src-shift ,bitsize))))
 489                                           (mask (start-mask (* final-bytes ,bitsize)))
 490                                           (orig (funcall dst-ref-fn dst dst-word-offset)))
 491                                       (declare (type word mask orig value))
 492                                       (funcall dst-set-fn dst dst-word-offset
 493                                                (word-logical-or (word-logical-and value mask)
 494                                                                 (word-logical-andc2 orig mask)))))))
 495                              (decf dst-word-offset)
 496                              (let ((end (- dst-word-offset interior)))
 497                                (do ()
 498                                    ((<= dst-word-offset end))
 499                                  (get-next-src)
 500                                  (let ((value (word-logical-or
 501                                                (shift-towards-end next (* (- src-shift) ,bitsize))
 502                                                (shift-towards-start prev (* src-shift ,bitsize)))))
 503                                    (declare (type word value))
 504                                    (funcall dst-set-fn dst dst-word-offset value)
 505                                    (decf dst-word-offset))))
 506                              ,@(unless (= bytes-per-word 1)
 507                                 `((unless (zerop dst-byte-offset)
 508                                     (if (> src-byte-offset dst-byte-offset)
 509                                         (get-next-src)
 510                                         (setf next prev prev 0))
 511                                     (let ((mask (end-mask (* (- dst-byte-offset) ,bitsize)))
 512                                           (orig (funcall dst-ref-fn dst dst-word-offset))
 513                                           (value (word-logical-or
 514                                                   (shift-towards-start prev (* src-shift ,bitsize))
 515                                                   (shift-towards-end next (* (- src-shift) ,bitsize)))))
 516                                       (declare (type word mask orig value))
 517                                       (funcall dst-set-fn dst dst-word-offset
 518                                               (word-logical-or (word-logical-and value mask)
 519                                                                (word-logical-andc2 orig mask)))))))))))))))))
 520            (values))
 521
 522          ;; common uses for unary-byte-bashing
 523          (defun ,array-copy-name (src src-offset dst dst-offset length)
 524            (declare (type ,offset src-offset dst-offset length))
 525            (locally (declare (optimize (speed 3) (safety 1)))
 526              (,unary-bash-name src src-offset dst dst-offset length
 527                                #'%vector-raw-bits
 528                                #'%set-vector-raw-bits
 529                                #'%vector-raw-bits)))
 530
 531          (defun ,system-area-copy-name (src src-offset dst dst-offset length)
 532            (declare (type ,offset src-offset dst-offset length))
 533            (locally (declare (optimize (speed 3) (safety 1)))
 534              (multiple-value-bind (src src-offset) (,fix-sap-and-offset-name src src-offset)
 535                (declare (type sb!sys:system-area-pointer src))
 536                (multiple-value-bind (dst dst-offset) (,fix-sap-and-offset-name dst dst-offset)
 537                  (declare (type sb!sys:system-area-pointer dst))
 538                  (,unary-bash-name src src-offset dst dst-offset length
 539                                    #'word-sap-ref #'%set-word-sap-ref
 540                                    #'word-sap-ref)))))
 541
 542          (defun ,array-copy-to-system-area-name (src src-offset dst dst-offset length)
 543            (declare (type ,offset src-offset dst-offset length))
 544            (locally (declare (optimize (speed 3) (safety 1)))
 545              (multiple-value-bind (dst dst-offset) (,fix-sap-and-offset-name  dst dst-offset)
 546                (,unary-bash-name src src-offset dst dst-offset length
 547                                  #'word-sap-ref #'%set-word-sap-ref
 548                                  #'%vector-raw-bits))))
 549
 550          (defun ,system-area-copy-to-array-name (src src-offset dst dst-offset length)
 551            (declare (type ,offset src-offset dst-offset length))
 552            (locally (declare (optimize (speed 3) (safety 1)))
 553              (multiple-value-bind (src src-offset) (,fix-sap-and-offset-name src src-offset)
 554                (,unary-bash-name src src-offset dst dst-offset length
 555                                  #'%vector-raw-bits
 556                                  #'%set-vector-raw-bits
 557                                  #'word-sap-ref)))))))
 558 ) ; EVAL-WHEN
 559
 560 ;;; We would normally do this with a MACROLET, but then we run into
 561 ;;; problems with the lexical environment being too hairy for the
 562 ;;; cross-compiler and it cannot inline the basic basher functions.
 563 #.(loop for i = 1 then (* i 2)
 564         collect `(!define-sap-fixer ,i) into fixers
 565         collect `(!define-byte-bashers ,i) into bashers
 566         until (= i sb!vm:n-word-bits)
 567         ;; FIXERS must come first so their inline expansions are available
 568         ;; for the bashers.
 569         finally (return `(progn ,@fixers ,@bashers)))
 570 \f
 571 ;;; a common idiom for calling COPY-TO-SYSTEM-AREA
 572 ;;;
 573 ;;; Copy the entire contents of the vector V to memory starting at SAP+OFFSET.
 574 (defun copy-byte-vector-to-system-area (bv sap &optional (offset 0))
 575   ;; FIXME: There should be a type like SB!VM:BYTE so that we can write this
 576   ;; type as (SIMPLE-ARRAY SB!VM:BYTE 1). Except BYTE is an external symbol of
 577   ;; package CL, and shadowing it would be too ugly; so maybe SB!VM:VMBYTE?
 578   ;; (And then N-BYTE-BITS would be N-VMBYTE-BITS and so forth?)
 579   (declare (type (simple-array (unsigned-byte 8) 1) bv))
 580   (declare (type system-area-pointer sap))
 581   (declare (type fixnum offset))
 582   (copy-ub8-to-system-area bv 0 sap offset (length bv)))