src/code/bit-bash.lisp

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