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