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