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