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~A" 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 (defmacro !define-byte-bashers (bitsize)
 132   (let* ((bytes-per-word (/ n-word-bits bitsize))
 133          (byte-offset `(integer 0 (,bytes-per-word)))
 134          (byte-count `(integer 1 (,bytes-per-word)))
 135          (max-bytes (ash most-positive-fixnum
 136                          ;; FIXME: this reflects code contained in the
 137                          ;; original bit-bash.lisp, but seems very
 138                          ;; nonsensical.  Why shouldn't we be able to
 139                          ;; handle M-P-FIXNUM bits?  And if we can't,
 140                          ;; are these other shift amounts bogus, too?
 141                          (ecase bitsize
 142                            (1 -2)
 143                            (2 -1)
 144                            (4  0)
 145                            (8  0)
 146                            (16 0)
 147                            (32 0)
 148                            (64 0))))
 149          (offset `(integer 0 ,max-bytes))
 150          (max-word-offset (ceiling max-bytes bytes-per-word))
 151          (word-offset `(integer 0 ,max-word-offset))
 152          (fix-sap-and-offset-name (intern (format nil "FIX-SAP-AND-OFFSET-UB~A" bitsize)))
 153          (constant-bash-name (intern (format nil "CONSTANT-UB~A-BASH" bitsize) (find-package "SB!KERNEL")))
 154          (array-fill-name (intern (format nil "UB~A-BASH-FILL" bitsize) (find-package "SB!KERNEL")))
 155          (system-area-fill-name (intern (format nil "SYSTEM-AREA-UB~A-FILL" bitsize) (find-package "SB!KERNEL")))
 156          (unary-bash-name (intern (format nil "UNARY-UB~A-BASH" bitsize) (find-package "SB!KERNEL")))
 157          (array-copy-name (intern (format nil "UB~A-BASH-COPY" bitsize) (find-package "SB!KERNEL")))
 158          (system-area-copy-name (intern (format nil "SYSTEM-AREA-UB~A-COPY" bitsize) (find-package "SB!KERNEL")))
 159          (array-copy-to-system-area-name
 160           (intern (format nil "COPY-UB~A-TO-SYSTEM-AREA" bitsize) (find-package "SB!KERNEL")))
 161          (system-area-copy-to-array-name
 162           (intern (format nil "COPY-UB~A-FROM-SYSTEM-AREA" bitsize)
 163                   (find-package "SB!KERNEL"))))
 164     `(progn
 165       (declaim (inline ,constant-bash-name ,unary-bash-name))
 166       ;; Fill DST with VALUE starting at DST-OFFSET and continuing
 167       ;; for LENGTH bytes (however bytes are defined).
 168       (defun ,constant-bash-name (dst dst-offset length value
 169                                       dst-ref-fn dst-set-fn)
 170         (declare (type word value) (type index dst-offset length))
 171         (declare (ignorable dst-ref-fn))
 172         (multiple-value-bind (dst-word-offset dst-byte-offset)
 173             (floor dst-offset ,bytes-per-word)
 174           (declare (type ,word-offset dst-word-offset)
 175                    (type ,byte-offset dst-byte-offset))
 176           (multiple-value-bind (n-words final-bytes)
 177               (floor (+ dst-byte-offset length) ,bytes-per-word)
 178             (declare (type ,word-offset n-words)
 179                      (type ,byte-offset final-bytes))
 180             (if (zerop n-words)
 181                 ,(unless (= bytes-per-word 1)
 182                   `(unless (zerop length)
 183                     (locally (declare (type ,byte-count length))
 184                       (funcall dst-set-fn dst dst-word-offset
 185                                (if (= length ,bytes-per-word)
 186                                    value
 187                                    (let ((mask (shift-towards-end
 188                                                 (start-mask (* length ,bitsize))
 189                                                 (* dst-byte-offset ,bitsize))))
 190                                      (word-logical-or (word-logical-and value mask)
 191                                                       (word-logical-andc2 (funcall dst-ref-fn dst dst-word-offset)
 192                                                                           mask))))))))
 193                 (let ((interior (floor (- length final-bytes) ,bytes-per-word)))
 194                   ,@(unless (= bytes-per-word 1)
 195                      `((unless (zerop dst-byte-offset)
 196                          (let ((mask (end-mask (* (- dst-byte-offset) ,bitsize))))
 197                            (funcall dst-set-fn dst dst-word-offset
 198                                     (word-logical-or (word-logical-and value mask)
 199                                                      (word-logical-andc2 (funcall dst-ref-fn dst dst-word-offset)
 200                                                                          mask))))
 201                          (incf dst-word-offset))))
 202                   (dotimes (i interior)
 203                     (funcall dst-set-fn dst dst-word-offset value)
 204                     (incf dst-word-offset))
 205                   ,@(unless (= bytes-per-word 1)
 206                      `((unless (zerop final-bytes)
 207                          (let ((mask (start-mask (* final-bytes ,bitsize))))
 208                            (funcall dst-set-fn dst dst-word-offset
 209                                     (word-logical-or (word-logical-and value mask)
 210                                                      (word-logical-andc2 (funcall dst-ref-fn dst dst-word-offset)
 211                                                                          mask)))))))))))
 212         (values))
 213
 214       ;; common uses for constant-byte-bashing
 215       (defun ,array-fill-name (value dst dst-offset length)
 216         (declare (type word value) (type ,offset dst-offset length))
 217         (declare (optimize (speed 3) (safety 1)))
 218         (,constant-bash-name dst dst-offset length value
 219                              #'%vector-raw-bits #'%set-vector-raw-bits))
 220       (defun ,system-area-fill-name (value dst dst-offset length)
 221         (declare (type word value) (type ,offset dst-offset length))
 222         (declare (optimize (speed 3) (safety 1)))
 223         (multiple-value-bind (dst dst-offset) (,fix-sap-and-offset-name dst dst-offset)
 224           (,constant-bash-name dst dst-offset length value
 225                                #'word-sap-ref #'%set-word-sap-ref)))
 226
 227          ;; unary byte bashing (copying)
 228          (defun ,unary-bash-name (src src-offset dst dst-offset length
 229                                       dst-ref-fn dst-set-fn src-ref-fn)
 230            (declare (type index src-offset dst-offset length)
 231                     (type function dst-ref-fn dst-set-fn src-ref-fn)
 232                     (ignorable dst-ref-fn))
 233            (multiple-value-bind (dst-word-offset dst-byte-offset)
 234                (floor dst-offset ,bytes-per-word)
 235              (declare (type ,word-offset dst-word-offset)
 236                       (type ,byte-offset dst-byte-offset))
 237              (multiple-value-bind (src-word-offset src-byte-offset)
 238                  (floor src-offset ,bytes-per-word)
 239                (declare (type ,word-offset src-word-offset)
 240                         (type ,byte-offset src-byte-offset))
 241                (cond
 242                  ((<= (+ dst-byte-offset length) ,bytes-per-word)
 243                   ;; We are only writing one word, so it doesn't matter what
 244                   ;; order we do it in.  But we might be reading from
 245                   ;; multiple words, so take care.
 246                   (cond
 247                     ((zerop length)
 248                      ;; We're not writing anything.  This is really easy.
 249                      )
 250                     ((= length ,bytes-per-word)
 251                      ;; DST-BYTE-OFFSET must be equal to zero, or we would be
 252                      ;; writing multiple words.  If SRC-BYTE-OFFSET is also zero,
 253                      ;; the we just transfer the single word.  Otherwise we have
 254                      ;; to extract bytes from two source words.
 255                      (funcall dst-set-fn dst dst-word-offset
 256                              (cond
 257                                ((zerop src-byte-offset)
 258                                 (funcall src-ref-fn src src-word-offset))
 259                                ,@(unless (= bytes-per-word 1)
 260                                   `((t (word-logical-or (shift-towards-start
 261                                                          (funcall src-ref-fn src src-word-offset)
 262                                                          (* src-byte-offset ,bitsize))
 263                                         (shift-towards-end
 264                                           (funcall src-ref-fn src (1+ src-word-offset))
 265                                           (* (- src-byte-offset) ,bitsize)))))))))
 266                     ,@(unless (= bytes-per-word 1)
 267                        `((t
 268                           ;; We are only writing some portion of the destination word.
 269                           ;; We still don't know whether we need one or two source words.
 270                           (locally (declare (type ,byte-count length))
 271                             (let ((mask (shift-towards-end (start-mask (* length ,bitsize))
 272                                                            (* dst-byte-offset ,bitsize)))
 273                                   (orig (funcall dst-ref-fn dst dst-word-offset))
 274                                   (value (if (> src-byte-offset dst-byte-offset)
 275                                              ;; The source starts further
 276                                              ;; into the word than does the
 277                                              ;; destination, so the source
 278                                              ;; could extend into the next
 279                                              ;; word.  If it does, we have
 280                                              ;; to merge the two words, and
 281                                              ;; it not, we can just shift
 282                                              ;; the first word.
 283                                              (let ((src-byte-shift (- src-byte-offset
 284                                                                       dst-byte-offset)))
 285                                                (if (> (+ src-byte-offset length) ,bytes-per-word)
 286                                                    (word-logical-or
 287                                                     (shift-towards-start
 288                                                      (funcall src-ref-fn src src-word-offset)
 289                                                      (* src-byte-shift ,bitsize))
 290                                                     (shift-towards-end
 291                                                      (funcall src-ref-fn src (1+ src-word-offset))
 292                                                      (* (- src-byte-shift) ,bitsize)))
 293                                                    (shift-towards-start (funcall src-ref-fn src src-word-offset)
 294                                                                         (* src-byte-shift ,bitsize))))
 295                                              ;; The destination starts further
 296                                              ;; into the word than does the
 297                                              ;; source, so we know the source
 298                                              ;; cannot extend into a second
 299                                              ;; word (or else the destination
 300                                              ;; would too, and we wouldn't be
 301                                              ;; in this branch).
 302                                              (shift-towards-end
 303                                               (funcall src-ref-fn src src-word-offset)
 304                                               (* (- dst-byte-offset src-byte-offset) ,bitsize)))))
 305                               (declare (type word mask orig value))
 306                               (funcall dst-set-fn dst dst-word-offset
 307                                        (word-logical-or (word-logical-and value mask)
 308                                                         (word-logical-andc2 orig mask))))))))))
 309                  ((= src-byte-offset dst-byte-offset)
 310                   ;; The source and destination are aligned, so shifting
 311                   ;; is unnecessary.  But we have to pick the direction
 312                   ;; of the copy in case the source and destination are
 313                   ;; really the same object.
 314                   (multiple-value-bind (words final-bytes)
 315                       (floor (+ dst-byte-offset length) ,bytes-per-word)
 316                     (declare (type ,word-offset words)
 317                              (type ,byte-offset final-bytes))
 318                     (let ((interior (floor (- length final-bytes) ,bytes-per-word)))
 319                       (declare (type ,word-offset interior))
 320                       (cond
 321                         ((<= dst-offset src-offset)
 322                          ;; We need to loop from left to right.
 323                          ,@(unless (= bytes-per-word 1)
 324                             `((unless (zerop dst-byte-offset)
 325                                 ;; We are only writing part of the first word, so mask
 326                                 ;; off the bytes we want to preserve.
 327                                 (let ((mask (end-mask (* (- dst-byte-offset) ,bitsize)))
 328                                       (orig (funcall dst-ref-fn dst dst-word-offset))
 329                                       (value (funcall src-ref-fn src src-word-offset)))
 330                                   (declare (type word mask orig value))
 331                                   (funcall dst-set-fn dst dst-word-offset
 332                                            (word-logical-or (word-logical-and value mask)
 333                                                             (word-logical-andc2 orig mask))))
 334                                 (incf src-word-offset)
 335                                 (incf dst-word-offset))))
 336                          ;; Copy the interior words.
 337                          (dotimes (i interior)
 338                            (funcall dst-set-fn dst dst-word-offset (funcall src-ref-fn src src-word-offset))
 339                            (incf src-word-offset)
 340                            (incf dst-word-offset))
 341                          ,@(unless (= bytes-per-word 1)
 342                             `((unless (zerop final-bytes)
 343                                 ;; We are only writing part of the last word.
 344                                 (let ((mask (start-mask (* final-bytes ,bitsize)))
 345                                       (orig (funcall dst-ref-fn dst dst-word-offset))
 346                                       (value (funcall src-ref-fn src src-word-offset)))
 347                                   (declare (type word mask orig value))
 348                                   (funcall dst-set-fn dst dst-word-offset
 349                                            (word-logical-or (word-logical-and value mask)
 350                                                             (word-logical-andc2 orig mask))))))))
 351                         (t
 352                          ;; We need to loop from right to left.
 353                          (incf dst-word-offset words)
 354                          (incf src-word-offset words)
 355                          ,@(unless (= bytes-per-word 1)
 356                             `((unless (zerop final-bytes)
 357                                 (let ((mask (start-mask (* final-bytes ,bitsize)))
 358                                       (orig (funcall dst-ref-fn dst dst-word-offset))
 359                                       (value (funcall src-ref-fn src src-word-offset)))
 360                                   (declare (type word mask orig value))
 361                                   (funcall dst-set-fn dst dst-word-offset
 362                                            (word-logical-or (word-logical-and value mask)
 363                                                             (word-logical-andc2 orig mask)))))))
 364                          (dotimes (i interior)
 365                            (decf src-word-offset)
 366                            (decf dst-word-offset)
 367                            (funcall dst-set-fn dst dst-word-offset (funcall src-ref-fn src src-word-offset)))
 368                          ,@(unless (= bytes-per-word 1)
 369                             `((unless (zerop dst-byte-offset)
 370                                 ;; We are only writing part of the last word.
 371                                 (decf src-word-offset)
 372                                 (decf dst-word-offset)
 373                                 (let ((mask (end-mask (* (- dst-byte-offset) ,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                   ;; Source and destination are not aligned.
 382                   (multiple-value-bind (words final-bytes)
 383                       (floor (+ dst-byte-offset length) ,bytes-per-word)
 384                     (declare (type ,word-offset words)
 385                              (type ,byte-offset final-bytes))
 386                     (let ((src-shift (mod (- src-byte-offset dst-byte-offset)
 387                                           ,bytes-per-word))
 388                           (interior (floor (- length final-bytes) ,bytes-per-word)))
 389                       (declare (type ,word-offset interior)
 390                                (type ,byte-offset src-shift))
 391                       (cond
 392                         ((<= dst-offset src-offset)
 393                          ;; We need to loop from left to right.
 394                          (let ((prev 0)
 395                                (next (funcall src-ref-fn src src-word-offset)))
 396                            (declare (type word prev next))
 397                            (flet ((get-next-src ()
 398                                     (setf prev next)
 399                                     (setf next (funcall src-ref-fn src (incf src-word-offset)))))
 400                              (declare (inline get-next-src))
 401                              ,@(unless (= bytes-per-word 1)
 402                                 `((unless (zerop dst-byte-offset)
 403                                     (when (> src-byte-offset dst-byte-offset)
 404                                       (get-next-src))
 405                                     (let ((mask (end-mask (* (- dst-byte-offset) ,bitsize)))
 406                                           (orig (funcall dst-ref-fn dst dst-word-offset))
 407                                           (value (word-logical-or (shift-towards-start prev (* src-shift ,bitsize))
 408                                                                   (shift-towards-end next (* (- src-shift) ,bitsize)))))
 409                                       (declare (type word mask orig value))
 410                                       (funcall dst-set-fn dst dst-word-offset
 411                                                (word-logical-or (word-logical-and value mask)
 412                                                                 (word-logical-andc2 orig mask))))
 413                                     (incf dst-word-offset))))
 414                              (dotimes (i interior)
 415                                (get-next-src)
 416                                (let ((value (word-logical-or
 417                                              (shift-towards-end next (* (- src-shift) ,bitsize))
 418                                              (shift-towards-start prev (* src-shift ,bitsize)))))
 419                                  (declare (type word value))
 420                                  (funcall dst-set-fn dst dst-word-offset value)
 421                                  (incf dst-word-offset)))
 422                              ,@(unless (= bytes-per-word 1)
 423                                 `((unless (zerop final-bytes)
 424                                     (let ((value
 425                                            (if (> (+ final-bytes src-shift) ,bytes-per-word)
 426                                                (progn
 427                                                  (get-next-src)
 428                                                  (word-logical-or
 429                                                   (shift-towards-end next (* (- src-shift) ,bitsize))
 430                                                   (shift-towards-start prev (* src-shift ,bitsize))))
 431                                                (shift-towards-start next (* src-shift ,bitsize))))
 432                                           (mask (start-mask (* final-bytes ,bitsize)))
 433                                           (orig (funcall dst-ref-fn dst dst-word-offset)))
 434                                       (declare (type word mask orig value))
 435                                       (funcall dst-set-fn dst dst-word-offset
 436                                                (word-logical-or (word-logical-and value mask)
 437                                                                 (word-logical-andc2 orig mask))))))))))
 438                         (t
 439                          ;; We need to loop from right to left.
 440                          (incf dst-word-offset words)
 441                          (incf src-word-offset
 442                                (1- (ceiling (+ src-byte-offset length) ,bytes-per-word)))
 443                          (let ((next 0)
 444                                (prev (funcall src-ref-fn src src-word-offset)))
 445                            (declare (type word prev next))
 446                            (flet ((get-next-src ()
 447                                     (setf next prev)
 448                                     (setf prev (funcall src-ref-fn src (decf src-word-offset)))))
 449                              (declare (inline get-next-src))
 450                              ,@(unless (= bytes-per-word 1)
 451                                 `((unless (zerop final-bytes)
 452                                     (when (> final-bytes (- ,bytes-per-word src-shift))
 453                                       (get-next-src))
 454                                     (let ((value (word-logical-or
 455                                                   (shift-towards-end next (* (- src-shift) ,bitsize))
 456                                                   (shift-towards-start prev (* src-shift ,bitsize))))
 457                                           (mask (start-mask (* final-bytes ,bitsize)))
 458                                           (orig (funcall dst-ref-fn dst dst-word-offset)))
 459                                       (declare (type word mask orig value))
 460                                       (funcall dst-set-fn dst dst-word-offset
 461                                                (word-logical-or (word-logical-and value mask)
 462                                                                 (word-logical-andc2 orig mask)))))))
 463                              (decf dst-word-offset)
 464                              (dotimes (i interior)
 465                                (get-next-src)
 466                                (let ((value (word-logical-or
 467                                              (shift-towards-end next (* (- src-shift) ,bitsize))
 468                                              (shift-towards-start prev (* src-shift ,bitsize)))))
 469                                  (declare (type word value))
 470                                  (funcall dst-set-fn dst dst-word-offset value)
 471                                  (decf dst-word-offset)))
 472                              ,@(unless (= bytes-per-word 1)
 473                                 `((unless (zerop dst-byte-offset)
 474                                     (if (> src-byte-offset dst-byte-offset)
 475                                         (get-next-src)
 476                                         (setf next prev prev 0))
 477                                     (let ((mask (end-mask (* (- dst-byte-offset) ,bitsize)))
 478                                           (orig (funcall dst-ref-fn dst dst-word-offset))
 479                                           (value (word-logical-or
 480                                                   (shift-towards-start prev (* src-shift ,bitsize))
 481                                                   (shift-towards-end next (* (- src-shift) ,bitsize)))))
 482                                       (declare (type word mask orig value))
 483                                       (funcall dst-set-fn dst dst-word-offset
 484                                               (word-logical-or (word-logical-and value mask)
 485                                                                (word-logical-andc2 orig mask)))))))))))))))))
 486            (values))
 487
 488          ;; common uses for unary-byte-bashing
 489          (defun ,array-copy-name (src src-offset dst dst-offset length)
 490            (declare (type ,offset src-offset dst-offset length))
 491            (locally (declare (optimize (speed 3) (safety 1)))
 492              (,unary-bash-name src src-offset dst dst-offset length
 493                                #'%vector-raw-bits
 494                                #'%set-vector-raw-bits
 495                                #'%vector-raw-bits)))
 496
 497          (defun ,system-area-copy-name (src src-offset dst dst-offset length)
 498            (declare (type ,offset src-offset dst-offset length))
 499            (locally (declare (optimize (speed 3) (safety 1)))
 500              (multiple-value-bind (src src-offset) (,fix-sap-and-offset-name src src-offset)
 501                (declare (type sb!sys:system-area-pointer src))
 502                (multiple-value-bind (dst dst-offset) (,fix-sap-and-offset-name dst dst-offset)
 503                  (declare (type sb!sys:system-area-pointer dst))
 504                  (,unary-bash-name src src-offset dst dst-offset length
 505                                    #'word-sap-ref #'%set-word-sap-ref
 506                                    #'word-sap-ref)))))
 507
 508          (defun ,array-copy-to-system-area-name (src src-offset dst dst-offset length)
 509            (declare (type ,offset src-offset dst-offset length))
 510            (locally (declare (optimize (speed 3) (safety 1)))
 511              (multiple-value-bind (dst dst-offset) (,fix-sap-and-offset-name  dst dst-offset)
 512                (,unary-bash-name src src-offset dst dst-offset length
 513                                  #'word-sap-ref #'%set-word-sap-ref
 514                                  #'%vector-raw-bits))))
 515
 516          (defun ,system-area-copy-to-array-name (src src-offset dst dst-offset length)
 517            (declare (type ,offset src-offset dst-offset length))
 518            (locally (declare (optimize (speed 3) (safety 1)))
 519              (multiple-value-bind (src src-offset) (,fix-sap-and-offset-name src src-offset)
 520                (,unary-bash-name src src-offset dst dst-offset length
 521                                  #'%vector-raw-bits
 522                                  #'%set-vector-raw-bits
 523                                  #'word-sap-ref)))))))
 524 ) ; EVAL-WHEN
 525
 526 ;;; We would normally do this with a MACROLET, but then we run into
 527 ;;; problems with the lexical environment being too hairy for the
 528 ;;; cross-compiler and it cannot inline the basic basher functions.
 529 #.(loop for i = 1 then (* i 2)
 530         collect `(!define-sap-fixer ,i) into fixers
 531         collect `(!define-byte-bashers ,i) into bashers
 532         until (= i sb!vm:n-word-bits)
 533         ;; FIXERS must come first so their inline expansions are available
 534         ;; for the bashers.
 535         finally (return `(progn ,@fixers ,@bashers)))
 536 \f
 537 ;;; a common idiom for calling COPY-TO-SYSTEM-AREA
 538 ;;;
 539 ;;; Copy the entire contents of the vector V to memory starting at SAP+OFFSET.
 540 (defun copy-byte-vector-to-system-area (bv sap &optional (offset 0))
 541   ;; FIXME: There should be a type like SB!VM:BYTE so that we can write this
 542   ;; type as (SIMPLE-ARRAY SB!VM:BYTE 1). Except BYTE is an external symbol of
 543   ;; package CL, and shadowing it would be too ugly; so maybe SB!VM:VMBYTE?
 544   ;; (And then N-BYTE-BITS would be N-VMBYTE-BITS and so forth?)
 545   (declare (type (simple-array (unsigned-byte 8) 1) bv))
 546   (declare (type system-area-pointer sap))
 547   (declare (type fixnum offset))
 548   (copy-ub8-to-system-area bv 0 sap offset (length bv)))