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 ;;;
 113 ;;; Well, it turns out that we *could* wrap a MACROLET around this,
 114 ;;; but it's quite ugly in a different way: when you write
 115 ;;;  (MACROLET ((GENERATOR () `(DEFUN F (X) ,@(INSANITY ...))) (GENERATOR)))
 116 ;;; and then view the inline expansion of F, you'll see it has actually
 117 ;;; captured the entirety of the MACROLET that surrounded it.
 118 ;;; With respect to building SBCL, this means, among other things, that
 119 ;;; it'd hang onto all the "!" symbols that would otherwise disappear,
 120 ;;; as well as kilobytes of completely useless s-expressions.
 121 (eval-when (:compile-toplevel :load-toplevel :execute)
 122
 123 ;;; Align the SAP to a word boundary, and update the offset accordingly.
 124 (defmacro !define-sap-fixer (bitsize)
 125   (let ((name (intern (format nil "FIX-SAP-AND-OFFSET-UB~D" bitsize))))
 126     `(progn
 127       (declaim (inline ,name))
 128       (defun ,name (sap offset)
 129         (declare (type system-area-pointer sap)
 130                  (type index offset)
 131                  (values system-area-pointer index))
 132         (let ((address (sap-int sap))
 133               (word-mask (1- (ash 1 word-shift))))
 134           (values (int-sap #!-alpha (word-logical-andc2 address word-mask)
 135                            ;; KLUDGE: WORD-LOGICAL-ANDC2 is defined in
 136                            ;; terms of n-word-bits.  On all systems
 137                            ;; where n-word-bits is not equal to
 138                            ;; n-machine-word-bits we have to do this
 139                            ;; another way.  At this time, these
 140                            ;; systems are alphas, though there was
 141                            ;; some talk about an x86-64 build option.
 142                            #!+alpha (ash (ash address (- word-shift)) word-shift))
 143                   (+ ,(ecase bitsize
 144                        ((1 2 4) `(* (logand address word-mask)
 145                                     (/ n-byte-bits ,bitsize)))
 146                        ((8 16 32 64) '(logand address word-mask)))
 147                      offset)))))))
 148
 149 ;;; We cheat a little bit by using TRULY-THE in the copying function to
 150 ;;; force the compiler to generate good code in the (= BITSIZE
 151 ;;; SB!VM:N-WORD-BITS) case.  We don't use TRULY-THE in the other cases
 152 ;;; to give the compiler freedom to generate better code.
 153 (defmacro !define-byte-bashers (bitsize)
 154   (let* ((bytes-per-word (/ n-word-bits bitsize))
 155          (byte-offset `(integer 0 (,bytes-per-word)))
 156          (byte-count `(integer 1 (,bytes-per-word)))
 157          (max-bytes (ash sb!xc:most-positive-fixnum
 158                          ;; FIXME: this reflects code contained in the
 159                          ;; original bit-bash.lisp, but seems very
 160                          ;; nonsensical.  Why shouldn't we be able to
 161                          ;; handle M-P-FIXNUM bits?  And if we can't,
 162                          ;; are these other shift amounts bogus, too?
 163                          (ecase bitsize
 164                            (1 -2)
 165                            (2 -1)
 166                            (4  0)
 167                            (8  0)
 168                            (16 0)
 169                            (32 0)
 170                            (64 0))))
 171          (offset `(integer 0 ,max-bytes))
 172          (max-word-offset (ceiling max-bytes bytes-per-word))
 173          (word-offset `(integer 0 ,max-word-offset))
 174          (fix-sap-and-offset-name (intern (format nil "FIX-SAP-AND-OFFSET-UB~D" bitsize)))
 175          (constant-bash-name (intern (format nil "CONSTANT-UB~D-BASH" bitsize) (find-package "SB!KERNEL")))
 176          (array-fill-name (intern (format nil "UB~D-BASH-FILL" bitsize) (find-package "SB!KERNEL")))
 177          (system-area-fill-name (intern (format nil "SYSTEM-AREA-UB~D-FILL" bitsize) (find-package "SB!KERNEL")))
 178          (unary-bash-name (intern (format nil "UNARY-UB~D-BASH" bitsize) (find-package "SB!KERNEL")))
 179          (array-copy-name (intern (format nil "UB~D-BASH-COPY" bitsize) (find-package "SB!KERNEL")))
 180          (system-area-copy-name (intern (format nil "SYSTEM-AREA-UB~D-COPY" bitsize) (find-package "SB!KERNEL")))
 181          (array-copy-to-system-area-name
 182           (intern (format nil "COPY-UB~D-TO-SYSTEM-AREA" bitsize) (find-package "SB!KERNEL")))
 183          (system-area-copy-to-array-name
 184           (intern (format nil "COPY-UB~D-FROM-SYSTEM-AREA" bitsize)
 185                   (find-package "SB!KERNEL"))))
 186     `(progn
 187       (declaim (inline ,constant-bash-name ,unary-bash-name))
 188       ;; Fill DST with VALUE starting at DST-OFFSET and continuing
 189       ;; for LENGTH bytes (however bytes are defined).
 190       (defun ,constant-bash-name (dst dst-offset length value
 191                                       dst-ref-fn dst-set-fn)
 192         (declare (type word value) (type index dst-offset length))
 193         (declare (ignorable dst-ref-fn))
 194         (multiple-value-bind (dst-word-offset dst-byte-offset)
 195             (floor dst-offset ,bytes-per-word)
 196           (declare (type ,word-offset dst-word-offset)
 197                    (type ,byte-offset dst-byte-offset))
 198           (multiple-value-bind (n-words final-bytes)
 199               (floor (+ dst-byte-offset length) ,bytes-per-word)
 200             (declare (type ,word-offset n-words)
 201                      (type ,byte-offset final-bytes))
 202             (if (zerop n-words)
 203                 ,(unless (= bytes-per-word 1)
 204                   `(unless (zerop length)
 205                     (locally (declare (type ,byte-count length))
 206                       (funcall dst-set-fn dst dst-word-offset
 207                                (if (= length ,bytes-per-word)
 208                                    value
 209                                    (let ((mask (shift-towards-end
 210                                                 (start-mask (* length ,bitsize))
 211                                                 (* dst-byte-offset ,bitsize))))
 212                                      (word-logical-or (word-logical-and value mask)
 213                                                       (word-logical-andc2 (funcall dst-ref-fn dst dst-word-offset)
 214                                                                           mask))))))))
 215                 (let ((interior (floor (- length final-bytes) ,bytes-per-word)))
 216                   ,@(unless (= bytes-per-word 1)
 217                      `((unless (zerop dst-byte-offset)
 218                          (let ((mask (end-mask (* (- dst-byte-offset) ,bitsize))))
 219                            (funcall dst-set-fn dst dst-word-offset
 220                                     (word-logical-or (word-logical-and value mask)
 221                                                      (word-logical-andc2 (funcall dst-ref-fn dst dst-word-offset)
 222                                                                          mask))))
 223                          (incf dst-word-offset))))
 224                   (let ((end (+ dst-word-offset interior)))
 225                     (declare (type ,word-offset end))
 226                     (do ()
 227                         ((>= dst-word-offset end))
 228                       (funcall dst-set-fn dst dst-word-offset value)
 229                       (incf dst-word-offset)))
 230                   #+nil
 231                   (dotimes (i interior)
 232                     (funcall dst-set-fn dst dst-word-offset value)
 233                     (incf dst-word-offset))
 234                   ,@(unless (= bytes-per-word 1)
 235                      `((unless (zerop final-bytes)
 236                          (let ((mask (start-mask (* final-bytes ,bitsize))))
 237                            (funcall dst-set-fn dst dst-word-offset
 238                                     (word-logical-or (word-logical-and value mask)
 239                                                      (word-logical-andc2 (funcall dst-ref-fn dst dst-word-offset)
 240                                                                          mask)))))))))))
 241         (values))
 242
 243       ;; common uses for constant-byte-bashing
 244       (defknown ,array-fill-name (word simple-unboxed-array ,offset ,offset)
 245           simple-unboxed-array
 246           ()
 247         :result-arg 1)
 248       (defun ,array-fill-name (value dst dst-offset length)
 249         (declare (type word value) (type ,offset dst-offset length))
 250         (declare (optimize (speed 3) (safety 1)))
 251         (,constant-bash-name dst dst-offset length value
 252                              #'%vector-raw-bits #'%set-vector-raw-bits)
 253         dst)
 254       (defun ,system-area-fill-name (value dst dst-offset length)
 255         (declare (type word value) (type ,offset dst-offset length))
 256         (declare (optimize (speed 3) (safety 1)))
 257         (multiple-value-bind (dst dst-offset) (,fix-sap-and-offset-name dst dst-offset)
 258           (,constant-bash-name dst dst-offset length value
 259                                #'word-sap-ref #'%set-word-sap-ref)))
 260
 261          ;; unary byte bashing (copying)
 262          (defun ,unary-bash-name (src src-offset dst dst-offset length
 263                                       dst-ref-fn dst-set-fn src-ref-fn)
 264            (declare (type index src-offset dst-offset length)
 265                     (type function dst-ref-fn dst-set-fn src-ref-fn)
 266                     (ignorable dst-ref-fn))
 267            (multiple-value-bind (dst-word-offset dst-byte-offset)
 268                (floor dst-offset ,bytes-per-word)
 269              (declare (type ,word-offset dst-word-offset)
 270                       (type ,byte-offset dst-byte-offset))
 271              (multiple-value-bind (src-word-offset src-byte-offset)
 272                  (floor src-offset ,bytes-per-word)
 273                (declare (type ,word-offset src-word-offset)
 274                         (type ,byte-offset src-byte-offset))
 275                (cond
 276                  ((<= (+ dst-byte-offset length) ,bytes-per-word)
 277                   ;; We are only writing one word, so it doesn't matter what
 278                   ;; order we do it in.  But we might be reading from
 279                   ;; multiple words, so take care.
 280                   (cond
 281                     ((zerop length)
 282                      ;; We're not writing anything.  This is really easy.
 283                      )
 284                     ((= length ,bytes-per-word)
 285                      ;; DST-BYTE-OFFSET must be equal to zero, or we would be
 286                      ;; writing multiple words.  If SRC-BYTE-OFFSET is also zero,
 287                      ;; the we just transfer the single word.  Otherwise we have
 288                      ;; to extract bytes from two source words.
 289                      (funcall dst-set-fn dst dst-word-offset
 290                              (cond
 291                                ((zerop src-byte-offset)
 292                                 (funcall src-ref-fn src src-word-offset))
 293                                ,@(unless (= bytes-per-word 1)
 294                                   `((t (word-logical-or (shift-towards-start
 295                                                          (funcall src-ref-fn src src-word-offset)
 296                                                          (* src-byte-offset ,bitsize))
 297                                         (shift-towards-end
 298                                           (funcall src-ref-fn src (1+ src-word-offset))
 299                                           (* (- src-byte-offset) ,bitsize)))))))))
 300                     ,@(unless (= bytes-per-word 1)
 301                        `((t
 302                           ;; We are only writing some portion of the destination word.
 303                           ;; We still don't know whether we need one or two source words.
 304                           (locally (declare (type ,byte-count length))
 305                             (let ((mask (shift-towards-end (start-mask (* length ,bitsize))
 306                                                            (* dst-byte-offset ,bitsize)))
 307                                   (orig (funcall dst-ref-fn dst dst-word-offset))
 308                                   (value (if (> src-byte-offset dst-byte-offset)
 309                                              ;; The source starts further
 310                                              ;; into the word than does the
 311                                              ;; destination, so the source
 312                                              ;; could extend into the next
 313                                              ;; word.  If it does, we have
 314                                              ;; to merge the two words, and
 315                                              ;; it not, we can just shift
 316                                              ;; the first word.
 317                                              (let ((src-byte-shift (- src-byte-offset
 318                                                                       dst-byte-offset)))
 319                                                (if (> (+ src-byte-offset length) ,bytes-per-word)
 320                                                    (word-logical-or
 321                                                     (shift-towards-start
 322                                                      (funcall src-ref-fn src src-word-offset)
 323                                                      (* src-byte-shift ,bitsize))
 324                                                     (shift-towards-end
 325                                                      (funcall src-ref-fn src (1+ src-word-offset))
 326                                                      (* (- src-byte-shift) ,bitsize)))
 327                                                    (shift-towards-start (funcall src-ref-fn src src-word-offset)
 328                                                                         (* src-byte-shift ,bitsize))))
 329                                              ;; The destination starts further
 330                                              ;; into the word than does the
 331                                              ;; source, so we know the source
 332                                              ;; cannot extend into a second
 333                                              ;; word (or else the destination
 334                                              ;; would too, and we wouldn't be
 335                                              ;; in this branch).
 336                                              (shift-towards-end
 337                                               (funcall src-ref-fn src src-word-offset)
 338                                               (* (- dst-byte-offset src-byte-offset) ,bitsize)))))
 339                               (declare (type word mask orig value))
 340                               (funcall dst-set-fn dst dst-word-offset
 341                                        (word-logical-or (word-logical-and value mask)
 342                                                         (word-logical-andc2 orig mask))))))))))
 343                  ((= src-byte-offset dst-byte-offset)
 344                   ;; The source and destination are aligned, so shifting
 345                   ;; is unnecessary.  But we have to pick the direction
 346                   ;; of the copy in case the source and destination are
 347                   ;; really the same object.
 348                   (multiple-value-bind (words final-bytes)
 349                       (floor (+ dst-byte-offset length) ,bytes-per-word)
 350                     (declare (type ,word-offset words)
 351                              (type ,byte-offset final-bytes))
 352                     (let ((interior (floor (- length final-bytes) ,bytes-per-word)))
 353                       (declare (type ,word-offset interior))
 354                       (cond
 355                         ((<= dst-offset src-offset)
 356                          ;; We need to loop from left to right.
 357                          ,@(unless (= bytes-per-word 1)
 358                             `((unless (zerop dst-byte-offset)
 359                                 ;; We are only writing part of the first word, so mask
 360                                 ;; off the bytes we want to preserve.
 361                                 (let ((mask (end-mask (* (- dst-byte-offset) ,bitsize)))
 362                                       (orig (funcall dst-ref-fn dst dst-word-offset))
 363                                       (value (funcall src-ref-fn src src-word-offset)))
 364                                   (declare (type word mask orig value))
 365                                   (funcall dst-set-fn dst dst-word-offset
 366                                            (word-logical-or (word-logical-and value mask)
 367                                                             (word-logical-andc2 orig mask))))
 368                                 (incf src-word-offset)
 369                                 (incf dst-word-offset))))
 370                          ;; Copy the interior words.
 371                          (let ((end ,(if (= bytes-per-word 1)
 372                                          `(truly-the ,word-offset
 373                                            (+ dst-word-offset interior))
 374                                          `(+ dst-word-offset interior))))
 375                            (declare (type ,word-offset end))
 376                            (do ()
 377                                ((>= dst-word-offset end))
 378                              (funcall dst-set-fn dst dst-word-offset
 379                                       (funcall src-ref-fn src src-word-offset))
 380                              ,(if (= bytes-per-word 1)
 381                                   `(setf src-word-offset (truly-the ,word-offset (+ src-word-offset 1)))
 382                                   `(incf src-word-offset))
 383                              (incf dst-word-offset)))
 384                          ,@(unless (= bytes-per-word 1)
 385                             `((unless (zerop final-bytes)
 386                                 ;; We are only writing part of the last word.
 387                                 (let ((mask (start-mask (* final-bytes ,bitsize)))
 388                                       (orig (funcall dst-ref-fn dst dst-word-offset))
 389                                       (value (funcall src-ref-fn src src-word-offset)))
 390                                   (declare (type word mask orig value))
 391                                   (funcall dst-set-fn dst dst-word-offset
 392                                            (word-logical-or (word-logical-and value mask)
 393                                                             (word-logical-andc2 orig mask))))))))
 394                         (t
 395                          ;; We need to loop from right to left.
 396                          ,(if (= bytes-per-word 1)
 397                               `(setf dst-word-offset (truly-the ,word-offset
 398                                                       (+ dst-word-offset words)))
 399                               `(incf dst-word-offset words))
 400                          ,(if (= bytes-per-word 1)
 401                               `(setf src-word-offset (truly-the ,word-offset
 402                                                       (+ src-word-offset words)))
 403                               `(incf src-word-offset words))
 404                          ,@(unless (= bytes-per-word 1)
 405                             `((unless (zerop final-bytes)
 406                                 (let ((mask (start-mask (* final-bytes ,bitsize)))
 407                                       (orig (funcall dst-ref-fn dst dst-word-offset))
 408                                       (value (funcall src-ref-fn src src-word-offset)))
 409                                   (declare (type word mask orig value))
 410                                   (funcall dst-set-fn dst dst-word-offset
 411                                            (word-logical-or (word-logical-and value mask)
 412                                                             (word-logical-andc2 orig mask)))))))
 413                          (let ((end (- dst-word-offset interior)))
 414                            (do ()
 415                                ((<= dst-word-offset end))
 416                              (decf src-word-offset)
 417                              (decf dst-word-offset)
 418                              (funcall dst-set-fn dst dst-word-offset
 419                                       (funcall src-ref-fn src src-word-offset))))
 420                          ,@(unless (= bytes-per-word 1)
 421                             `((unless (zerop dst-byte-offset)
 422                                 ;; We are only writing part of the last word.
 423                                 (decf src-word-offset)
 424                                 (decf dst-word-offset)
 425                                 (let ((mask (end-mask (* (- dst-byte-offset) ,bitsize)))
 426                                       (orig (funcall dst-ref-fn dst dst-word-offset))
 427                                       (value (funcall src-ref-fn src src-word-offset)))
 428                                   (declare (type word mask orig value))
 429                                   (funcall dst-set-fn dst dst-word-offset
 430                                            (word-logical-or (word-logical-and value mask)
 431                                                             (word-logical-andc2 orig mask))))))))))))
 432                  (t
 433                   ;; Source and destination are not aligned.
 434                   (multiple-value-bind (words final-bytes)
 435                       (floor (+ dst-byte-offset length) ,bytes-per-word)
 436                     (declare (type ,word-offset words)
 437                              (type ,byte-offset final-bytes))
 438                     (let ((src-shift (mod (- src-byte-offset dst-byte-offset)
 439                                           ,bytes-per-word))
 440                           (interior (floor (- length final-bytes) ,bytes-per-word)))
 441                       (declare (type ,word-offset interior)
 442                                (type ,byte-offset src-shift))
 443                       (cond
 444                         ((<= dst-offset src-offset)
 445                          ;; We need to loop from left to right.
 446                          (let ((prev 0)
 447                                (next (funcall src-ref-fn src src-word-offset)))
 448                            (declare (type word prev next))
 449                            (flet ((get-next-src ()
 450                                     (setf prev next)
 451                                     (setf next (funcall src-ref-fn src
 452                                                         (incf src-word-offset)))))
 453                              (declare (inline get-next-src))
 454                              ,@(unless (= bytes-per-word 1)
 455                                 `((unless (zerop dst-byte-offset)
 456                                     (when (> src-byte-offset dst-byte-offset)
 457                                       (get-next-src))
 458                                     (let ((mask (end-mask (* (- dst-byte-offset) ,bitsize)))
 459                                           (orig (funcall dst-ref-fn dst dst-word-offset))
 460                                           (value (word-logical-or (shift-towards-start prev (* src-shift ,bitsize))
 461                                                                   (shift-towards-end next (* (- src-shift) ,bitsize)))))
 462                                       (declare (type word mask orig value))
 463                                       (funcall dst-set-fn dst dst-word-offset
 464                                                (word-logical-or (word-logical-and value mask)
 465                                                                 (word-logical-andc2 orig mask))))
 466                                     (incf dst-word-offset))))
 467                              (let ((end (+ dst-word-offset interior)))
 468                                (declare (type ,word-offset end))
 469                                (do ()
 470                                    ((>= dst-word-offset end))
 471                                  (get-next-src)
 472                                  (let ((value (word-logical-or
 473                                                (shift-towards-end next (* (- src-shift) ,bitsize))
 474                                                (shift-towards-start prev (* src-shift ,bitsize)))))
 475                                    (declare (type word value))
 476                                    (funcall dst-set-fn dst dst-word-offset value)
 477                                    (incf dst-word-offset))))
 478                              ,@(unless (= bytes-per-word 1)
 479                                 `((unless (zerop final-bytes)
 480                                     (let ((value
 481                                            (if (> (+ final-bytes src-shift) ,bytes-per-word)
 482                                                (progn
 483                                                  (get-next-src)
 484                                                  (word-logical-or
 485                                                   (shift-towards-end next (* (- src-shift) ,bitsize))
 486                                                   (shift-towards-start prev (* src-shift ,bitsize))))
 487                                                (shift-towards-start next (* src-shift ,bitsize))))
 488                                           (mask (start-mask (* final-bytes ,bitsize)))
 489                                           (orig (funcall dst-ref-fn dst dst-word-offset)))
 490                                       (declare (type word mask orig value))
 491                                       (funcall dst-set-fn dst dst-word-offset
 492                                                (word-logical-or (word-logical-and value mask)
 493                                                                 (word-logical-andc2 orig mask))))))))))
 494                         (t
 495                          ;; We need to loop from right to left.
 496                          (incf dst-word-offset words)
 497                          (incf src-word-offset (1- (ceiling (+ src-byte-offset length) ,bytes-per-word)))
 498                          (let ((next 0)
 499                                (prev (funcall src-ref-fn src src-word-offset)))
 500                            (declare (type word prev next))
 501                            (flet ((get-next-src ()
 502                                     (setf next prev)
 503                                     (setf prev (funcall src-ref-fn src (decf src-word-offset)))))
 504                              (declare (inline get-next-src))
 505                              ,@(unless (= bytes-per-word 1)
 506                                 `((unless (zerop final-bytes)
 507                                     (when (> final-bytes (- ,bytes-per-word src-shift))
 508                                       (get-next-src))
 509                                     (let ((value (word-logical-or
 510                                                   (shift-towards-end next (* (- src-shift) ,bitsize))
 511                                                   (shift-towards-start prev (* src-shift ,bitsize))))
 512                                           (mask (start-mask (* final-bytes ,bitsize)))
 513                                           (orig (funcall dst-ref-fn dst dst-word-offset)))
 514                                       (declare (type word mask orig value))
 515                                       (funcall dst-set-fn dst dst-word-offset
 516                                                (word-logical-or (word-logical-and value mask)
 517                                                                 (word-logical-andc2 orig mask)))))))
 518                              (decf dst-word-offset)
 519                              (let ((end (- dst-word-offset interior)))
 520                                (do ()
 521                                    ((<= dst-word-offset end))
 522                                  (get-next-src)
 523                                  (let ((value (word-logical-or
 524                                                (shift-towards-end next (* (- src-shift) ,bitsize))
 525                                                (shift-towards-start prev (* src-shift ,bitsize)))))
 526                                    (declare (type word value))
 527                                    (funcall dst-set-fn dst dst-word-offset value)
 528                                    (decf dst-word-offset))))
 529                              ,@(unless (= bytes-per-word 1)
 530                                 `((unless (zerop dst-byte-offset)
 531                                     (if (> src-byte-offset dst-byte-offset)
 532                                         (get-next-src)
 533                                         (setf next prev prev 0))
 534                                     (let ((mask (end-mask (* (- dst-byte-offset) ,bitsize)))
 535                                           (orig (funcall dst-ref-fn dst dst-word-offset))
 536                                           (value (word-logical-or
 537                                                   (shift-towards-start prev (* src-shift ,bitsize))
 538                                                   (shift-towards-end next (* (- src-shift) ,bitsize)))))
 539                                       (declare (type word mask orig value))
 540                                       (funcall dst-set-fn dst dst-word-offset
 541                                               (word-logical-or (word-logical-and value mask)
 542                                                                (word-logical-andc2 orig mask)))))))))))))))))
 543            (values))
 544
 545          ;; common uses for unary-byte-bashing
 546          (defun ,array-copy-name (src src-offset dst dst-offset length)
 547            (declare (type ,offset src-offset dst-offset length))
 548            (locally (declare (optimize (speed 3) (safety 1)))
 549              (,unary-bash-name src src-offset dst dst-offset length
 550                                #'%vector-raw-bits
 551                                #'%set-vector-raw-bits
 552                                #'%vector-raw-bits)))
 553
 554          (defun ,system-area-copy-name (src src-offset dst dst-offset length)
 555            (declare (type ,offset src-offset dst-offset length))
 556            (locally (declare (optimize (speed 3) (safety 1)))
 557              (multiple-value-bind (src src-offset) (,fix-sap-and-offset-name src src-offset)
 558                (declare (type system-area-pointer src))
 559                (multiple-value-bind (dst dst-offset) (,fix-sap-and-offset-name dst dst-offset)
 560                  (declare (type system-area-pointer dst))
 561                  (,unary-bash-name src src-offset dst dst-offset length
 562                                    #'word-sap-ref #'%set-word-sap-ref
 563                                    #'word-sap-ref)))))
 564
 565          (defun ,array-copy-to-system-area-name (src src-offset dst dst-offset length)
 566            (declare (type ,offset src-offset dst-offset length))
 567            (locally (declare (optimize (speed 3) (safety 1)))
 568              (multiple-value-bind (dst dst-offset) (,fix-sap-and-offset-name  dst dst-offset)
 569                (,unary-bash-name src src-offset dst dst-offset length
 570                                  #'word-sap-ref #'%set-word-sap-ref
 571                                  #'%vector-raw-bits))))
 572
 573          (defun ,system-area-copy-to-array-name (src src-offset dst dst-offset length)
 574            (declare (type ,offset src-offset dst-offset length))
 575            (locally (declare (optimize (speed 3) (safety 1)))
 576              (multiple-value-bind (src src-offset) (,fix-sap-and-offset-name src src-offset)
 577                (,unary-bash-name src src-offset dst dst-offset length
 578                                  #'%vector-raw-bits
 579                                  #'%set-vector-raw-bits
 580                                  #'word-sap-ref)))))))
 581 ) ; EVAL-WHEN
 582
 583 (eval-when (:compile-toplevel)
 584   (sb!xc:proclaim '(muffle-conditions compiler-note)))
 585 ;;; We would normally do this with a MACROLET, but then we run into
 586 ;;; problems with the lexical environment being too hairy for the
 587 ;;; cross-compiler and it cannot inline the basic basher functions.
 588 #.(loop for i = 1 then (* i 2)
 589         collect `(!define-sap-fixer ,i) into fixers
 590         collect `(!define-byte-bashers ,i) into bashers
 591         until (= i sb!vm:n-word-bits)
 592         ;; FIXERS must come first so their inline expansions are available
 593         ;; for the bashers.
 594         finally (return `(progn ,@fixers ,@bashers)))
 595 \f
 596 ;;; a common idiom for calling COPY-TO-SYSTEM-AREA
 597 ;;;
 598 ;;; Copy the entire contents of the vector V to memory starting at SAP+OFFSET.
 599 (defun copy-byte-vector-to-system-area (bv sap &optional (offset 0))
 600   ;; FIXME: There should be a type like SB!VM:BYTE so that we can write this
 601   ;; type as (SIMPLE-ARRAY SB!VM:BYTE 1). Except BYTE is an external symbol of
 602   ;; package CL, and shadowing it would be too ugly; so maybe SB!VM:VMBYTE?
 603   ;; (And then N-BYTE-BITS would be N-VMBYTE-BITS and so forth?)
 604   (declare (type (simple-array (unsigned-byte 8) 1) bv))
 605   (declare (type system-area-pointer sap))
 606   (declare (type fixnum offset))
 607   (copy-ub8-to-system-area bv 0 sap offset (length bv)))
 608
 609 \f
 610 ;;;; Bashing-Style search for bits
 611 ;;;;
 612 ;;;; Similar search would work well for base-strings as well.
 613 ;;;; (Technically for all unboxed sequences of sub-word size elements,
 614 ;;;; but somehow I doubt eg. octet vectors get POSITION or FIND used
 615 ;;;; as much on them.)
 616 (defconstant +bit-position-base-mask+ (1- n-word-bits))
 617 (defconstant +bit-position-base-shift+ (integer-length +bit-position-base-mask+))
 618 (macrolet ((def (name frob)
 619              `(defun ,name (vector from-end start end)
 620                 (declare (simple-bit-vector vector)
 621                          (index start end)
 622                          (optimize (speed 3) (safety 0)))
 623                 (unless (= start end)
 624                   (let* ((last-word (ash end (- +bit-position-base-shift+)))
 625                          (last-bits (logand end +bit-position-base-mask+))
 626                          (first-word (ash start (- +bit-position-base-shift+)))
 627                          (first-bits (logand start +bit-position-base-mask+))
 628                          ;; These mask out everything but the interesting parts.
 629                          (end-mask #!+little-endian (lognot (ash -1 last-bits))
 630                                    #!+big-endian (ash -1 (- sb!vm:n-word-bits last-bits)))
 631                          (start-mask #!+little-endian (ash -1 first-bits)
 632                                      #!+big-endian (lognot (ash -1 (- sb!vm:n-word-bits first-bits)))))
 633                     (declare (index last-word first-word))
 634                     (flet ((#!+little-endian start-bit
 635                             #!+big-endian end-bit (x)
 636                              (declare (word x))
 637                              #!+(or x86-64 x86)
 638                              (truly-the (mod #.n-word-bits)
 639                                  (%primitive unsigned-word-find-first-bit x))
 640                              #!-(or x86-64 x86)
 641                              (- #!+big-endian sb!vm:n-word-bits
 642                                 (integer-length (logand x (- x)))
 643                                 #!+little-endian 1))
 644                            (#!+little-endian end-bit
 645                             #!+big-endian start-bit (x)
 646                              (declare (word x))
 647                              (- #!+big-endian sb!vm:n-word-bits
 648                                 (integer-length x)
 649                                 #!+little-endian 1))
 650                            (found (i word-offset)
 651                              (declare (index i word-offset))
 652                              (return-from ,name
 653                                (logior i (truly-the
 654                                           fixnum
 655                                           (ash word-offset +bit-position-base-shift+)))))
 656                            (get-word (offset)
 657                              (,@frob (%vector-raw-bits vector offset))))
 658                       ;; Inline FOUND makes the code smaller, as well as faster,
 659                       ;; because it becomes clear that there is no establishing
 660                       ;; of an exit point and hence no call to UNWIND.
 661                       (declare (inline start-bit end-bit found get-word))
 662                       (if from-end
 663                           ;; Back to front
 664                           (let* ((word-offset last-word)
 665                                  (word (logand end-mask (get-word word-offset))))
 666                             (declare (word word)
 667                                      (index word-offset))
 668                             (unless (zerop word)
 669                               (when (= word-offset first-word)
 670                                 (setf word (logand word start-mask)))
 671                               (unless (zerop word)
 672                                 (found (end-bit word) word-offset)))
 673                             (decf word-offset)
 674                             (loop
 675                               (when (< word-offset first-word)
 676                                 (return-from ,name nil))
 677                               (setf word (get-word word-offset))
 678                               (unless (zerop word)
 679                                 (when (= word-offset first-word)
 680                                   (setf word (logand word start-mask)))
 681                                 (unless (zerop word)
 682                                   (found (end-bit word) word-offset)))
 683                               (decf word-offset)))
 684                           ;; Front to back
 685                           (let* ((word-offset first-word)
 686                                  (word (logand start-mask (get-word word-offset))))
 687                             (declare (word word)
 688                                      (index word-offset))
 689                             (unless (zerop word)
 690                               (when (= word-offset last-word)
 691                                 (setf word (logand word end-mask)))
 692                               (unless (zerop word)
 693                                 (found (start-bit word) word-offset)))
 694                             (incf word-offset)
 695                             (loop
 696                               (when (> word-offset last-word)
 697                                 (return-from ,name nil))
 698                               (setf word (get-word word-offset))
 699                               (unless (zerop word)
 700                                 (when (= word-offset last-word)
 701                                   (setf word (logand word end-mask)))
 702                                 (unless (zerop word)
 703                                   (found (start-bit word) word-offset)))
 704                               (incf word-offset))))))))))
 705   (def %bit-position/0 (logandc2 #.(1- (expt 2 n-word-bits))))
 706   (def %bit-position/1 (identity)))
 707 (defun %bit-position (bit vector from-end start end)
 708   (case bit
 709     (0 (%bit-position/0 vector from-end start end))
 710     (1 (%bit-position/1 vector from-end start end))
 711     (otherwise nil)))