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 ;;;; constants and types
  15
  16 ;;; the number of bits to process at a time
  17 (defconstant unit-bits sb!vm:word-bits)
  18
  19 ;;; the maximum number of bits that can be dealt with in a single call
  20 (defconstant max-bits (ash most-positive-fixnum -2))
  21
  22 (deftype unit ()
  23   `(unsigned-byte ,unit-bits))
  24
  25 (deftype offset ()
  26   `(integer 0 ,max-bits))
  27
  28 (deftype bit-offset ()
  29   `(integer 0 (,unit-bits)))
  30
  31 (deftype bit-count ()
  32   `(integer 1 (,unit-bits)))
  33
  34 (deftype word-offset ()
  35   `(integer 0 (,(ceiling max-bits unit-bits))))
  36 \f
  37 ;;;; support routines
  38
  39 ;;; A particular implementation must offer either VOPs to translate
  40 ;;; these, or DEFTRANSFORMs to convert them into something supported
  41 ;;; by the architecture.
  42 (macrolet ((def-frob (name &rest args)
  43              `(defun ,name ,args
  44                 (,name ,@args))))
  45   (def-frob 32bit-logical-not x)
  46   (def-frob 32bit-logical-and x y)
  47   (def-frob 32bit-logical-or x y)
  48   (def-frob 32bit-logical-xor x y)
  49   (def-frob 32bit-logical-nor x y)
  50   (def-frob 32bit-logical-eqv x y)
  51   (def-frob 32bit-logical-nand x y)
  52   (def-frob 32bit-logical-andc1 x y)
  53   (def-frob 32bit-logical-andc2 x y)
  54   (def-frob 32bit-logical-orc1 x y)
  55   (def-frob 32bit-logical-orc2 x y))
  56
  57 ;;; Shift NUMBER by the low-order bits of COUNTOID, adding zero bits
  58 ;;; at the "end" and removing bits from the "start". On big-endian
  59 ;;; machines this is a left-shift and on little-endian machines this
  60 ;;; is a right-shift.
  61 (defun shift-towards-start (number countoid)
  62   (declare (type unit number) (fixnum countoid))
  63   (let ((count (ldb (byte (1- (integer-length unit-bits)) 0) countoid)))
  64     (declare (type bit-offset count))
  65     (if (zerop count)
  66         number
  67         (ecase sb!c:*backend-byte-order*
  68           (:big-endian
  69            (ash (ldb (byte (- unit-bits count) 0) number) count))
  70           (:little-endian
  71            (ash number (- count)))))))
  72
  73 ;;; Shift NUMBER by COUNT bits, adding zero bits at the "start" and
  74 ;;; removing bits from the "end". On big-endian machines this is a
  75 ;;; right-shift and on little-endian machines this is a left-shift.
  76 (defun shift-towards-end (number count)
  77   (declare (type unit number) (fixnum count))
  78   (let ((count (ldb (byte (1- (integer-length unit-bits)) 0) count)))
  79     (declare (type bit-offset count))
  80     (if (zerop count)
  81         number
  82         (ecase sb!c:*backend-byte-order*
  83           (:big-endian
  84            (ash number (- count)))
  85           (:little-endian
  86            (ash (ldb (byte (- unit-bits count) 0) number) count))))))
  87
  88 #!-sb-fluid (declaim (inline start-mask end-mask fix-sap-and-offset))
  89
  90 ;;; Produce a mask that contains 1's for the COUNT "start" bits and
  91 ;;; 0's for the remaining "end" bits. Only the lower 5 bits of COUNT
  92 ;;; are significant (KLUDGE: because of hardwired implicit dependence
  93 ;;; on 32-bit word size -- WHN 2001-03-19).
  94 (defun start-mask (count)
  95   (declare (fixnum count))
  96   (shift-towards-start (1- (ash 1 unit-bits)) (- count)))
  97
  98 ;;; Produce a mask that contains 1's for the COUNT "end" bits and 0's
  99 ;;; for the remaining "start" bits. Only the lower 5 bits of COUNT are
 100 ;;; significant (KLUDGE: because of hardwired implicit dependence on
 101 ;;; 32-bit word size -- WHN 2001-03-19).
 102 (defun end-mask (count)
 103   (declare (fixnum count))
 104   (shift-towards-end (1- (ash 1 unit-bits)) (- count)))
 105
 106 ;;; Align the SAP to a word boundary, and update the offset accordingly.
 107 (defun fix-sap-and-offset (sap offset)
 108   (declare (type system-area-pointer sap)
 109            (type index offset)
 110            (values system-area-pointer index))
 111   (let ((address (sap-int sap)))
 112     (values (int-sap #!-alpha (32bit-logical-andc2 address 3)
 113                      #!+alpha (ash (ash address -2) 2))
 114             (+ (* (logand address 3) byte-bits) offset))))
 115
 116 #!-sb-fluid (declaim (inline word-sap-ref %set-word-sap-ref))
 117 (defun word-sap-ref (sap offset)
 118   (declare (type system-area-pointer sap)
 119            (type index offset)
 120            (values (unsigned-byte 32))
 121            (optimize (speed 3) (safety 0) #-sb-xc-host (inhibit-warnings 3)))
 122   (sap-ref-32 sap (the index (ash offset 2))))
 123 (defun %set-word-sap-ref (sap offset value)
 124   (declare (type system-area-pointer sap)
 125            (type index offset)
 126            (type (unsigned-byte 32) value)
 127            (values (unsigned-byte 32))
 128            (optimize (speed 3) (safety 0) (inhibit-warnings 3)))
 129   (setf (sap-ref-32 sap (the index (ash offset 2))) value))
 130 \f
 131 ;;;; DO-CONSTANT-BIT-BASH
 132
 133 ;;; Fill DST with VALUE starting at DST-OFFSET and continuing for
 134 ;;; LENGTH bits.
 135 #!-sb-fluid (declaim (inline do-constant-bit-bash))
 136 (defun do-constant-bit-bash (dst dst-offset length value dst-ref-fn dst-set-fn)
 137   (declare (type offset dst-offset) (type unit value)
 138            (type function dst-ref-fn dst-set-fn))
 139   (multiple-value-bind (dst-word-offset dst-bit-offset)
 140       (floor dst-offset unit-bits)
 141     (declare (type word-offset dst-word-offset)
 142              (type bit-offset dst-bit-offset))
 143     (multiple-value-bind (words final-bits)
 144         (floor (+ dst-bit-offset length) unit-bits)
 145       (declare (type word-offset words) (type bit-offset final-bits))
 146       (if (zerop words)
 147           (unless (zerop length)
 148             (funcall dst-set-fn dst dst-word-offset
 149                      (if (= length unit-bits)
 150                          value
 151                          (let ((mask (shift-towards-end (start-mask length)
 152                                                         dst-bit-offset)))
 153                            (declare (type unit mask))
 154                            (32bit-logical-or
 155                             (32bit-logical-and value mask)
 156                             (32bit-logical-andc2
 157                              (funcall dst-ref-fn dst dst-word-offset)
 158                              mask))))))
 159           (let ((interior (floor (- length final-bits) unit-bits)))
 160             (unless (zerop dst-bit-offset)
 161               (let ((mask (end-mask (- dst-bit-offset))))
 162                 (declare (type unit mask))
 163                 (funcall dst-set-fn dst dst-word-offset
 164                          (32bit-logical-or
 165                           (32bit-logical-and value mask)
 166                           (32bit-logical-andc2
 167                            (funcall dst-ref-fn dst dst-word-offset)
 168                            mask))))
 169               (incf dst-word-offset))
 170             (dotimes (i interior)
 171               (funcall dst-set-fn dst dst-word-offset value)
 172               (incf dst-word-offset))
 173             (unless (zerop final-bits)
 174               (let ((mask (start-mask final-bits)))
 175                 (declare (type unit mask))
 176                 (funcall dst-set-fn dst dst-word-offset
 177                          (32bit-logical-or
 178                           (32bit-logical-and value mask)
 179                           (32bit-logical-andc2
 180                            (funcall dst-ref-fn dst dst-word-offset)
 181                            mask)))))))))
 182   (values))
 183 \f
 184 ;;;; DO-UNARY-BIT-BASH
 185
 186 #!-sb-fluid (declaim (inline do-unary-bit-bash))
 187 (defun do-unary-bit-bash (src src-offset dst dst-offset length
 188                               dst-ref-fn dst-set-fn src-ref-fn)
 189   (declare (type offset src-offset dst-offset length)
 190            (type function dst-ref-fn dst-set-fn src-ref-fn))
 191   (multiple-value-bind (dst-word-offset dst-bit-offset)
 192       (floor dst-offset unit-bits)
 193     (declare (type word-offset dst-word-offset)
 194              (type bit-offset dst-bit-offset))
 195     (multiple-value-bind (src-word-offset src-bit-offset)
 196         (floor src-offset unit-bits)
 197       (declare (type word-offset src-word-offset)
 198                (type bit-offset src-bit-offset))
 199       (cond
 200        ((<= (+ dst-bit-offset length) unit-bits)
 201         ;; We are only writing one word, so it doesn't matter what
 202         ;; order we do it in. But we might be reading from multiple
 203         ;; words, so take care.
 204         (cond
 205          ((zerop length)
 206           ;; Actually, we aren't even writing one word. This is really easy.
 207           )
 208          ((= length unit-bits)
 209           ;; DST-BIT-OFFSET must be equal to zero, or we would be
 210           ;; writing multiple words. If SRC-BIT-OFFSET is also zero,
 211           ;; then we just transfer the single word. Otherwise we have
 212           ;; to extract bits from two src words.
 213           (funcall dst-set-fn dst dst-word-offset
 214                    (if (zerop src-bit-offset)
 215                        (funcall src-ref-fn src src-word-offset)
 216                        (32bit-logical-or
 217                         (shift-towards-start
 218                          (funcall src-ref-fn src src-word-offset)
 219                          src-bit-offset)
 220                         (shift-towards-end
 221                          (funcall src-ref-fn src (1+ src-word-offset))
 222                          (- src-bit-offset))))))
 223          (t
 224           ;; We are only writing some portion of the dst word, so we
 225           ;; need to preserve the extra bits. Also, we still don't
 226           ;; know whether we need one or two source words.
 227           (let ((mask (shift-towards-end (start-mask length) dst-bit-offset))
 228                 (orig (funcall dst-ref-fn dst dst-word-offset))
 229                 (value
 230                  (if (> src-bit-offset dst-bit-offset)
 231                      ;; The source starts further into the word than
 232                      ;; does the dst, so the source could extend into
 233                      ;; the next word. If it does, we have to merge
 234                      ;; the two words, and if not, we can just shift
 235                      ;; the first word.
 236                      (let ((src-bit-shift (- src-bit-offset dst-bit-offset)))
 237                        (if (> (+ src-bit-offset length) unit-bits)
 238                            (32bit-logical-or
 239                             (shift-towards-start
 240                              (funcall src-ref-fn src src-word-offset)
 241                              src-bit-shift)
 242                             (shift-towards-end
 243                              (funcall src-ref-fn src (1+ src-word-offset))
 244                              (- src-bit-shift)))
 245                            (shift-towards-start
 246                             (funcall src-ref-fn src src-word-offset)
 247                             src-bit-shift)))
 248                      ;; The dst starts further into the word than does
 249                      ;; the source, so we know the source can not
 250                      ;; extend into a second word (or else the dst
 251                      ;; would too, and we wouldn't be in this branch.
 252                      (shift-towards-end
 253                       (funcall src-ref-fn src src-word-offset)
 254                       (- dst-bit-offset src-bit-offset)))))
 255             (declare (type unit mask orig value))
 256             ;; Replace the dst word.
 257             (funcall dst-set-fn dst dst-word-offset
 258                      (32bit-logical-or
 259                       (32bit-logical-and value mask)
 260                       (32bit-logical-andc2 orig mask)))))))
 261        ((= src-bit-offset dst-bit-offset)
 262         ;; The source and dst are aligned, so we don't need to shift
 263         ;; anything. But we have to pick the direction of the loop in
 264         ;; case the source and dst are really the same thing.
 265         (multiple-value-bind (words final-bits)
 266             (floor (+ dst-bit-offset length) unit-bits)
 267           (declare (type word-offset words) (type bit-offset final-bits))
 268           (let ((interior (floor (- length final-bits) unit-bits)))
 269             (declare (type word-offset interior))
 270             (cond
 271              ((<= dst-offset src-offset)
 272               ;; We need to loop from left to right
 273               (unless (zerop dst-bit-offset)
 274                 ;; We are only writing part of the first word, so mask
 275                 ;; off the bits we want to preserve.
 276                 (let ((mask (end-mask (- dst-bit-offset)))
 277                       (orig (funcall dst-ref-fn dst dst-word-offset))
 278                       (value (funcall src-ref-fn src src-word-offset)))
 279                   (declare (type unit mask orig value))
 280                   (funcall dst-set-fn dst dst-word-offset
 281                            (32bit-logical-or (32bit-logical-and value mask)
 282                                              (32bit-logical-andc2 orig mask))))
 283                 (incf src-word-offset)
 284                 (incf dst-word-offset))
 285               ;; Just copy the interior words.
 286               (dotimes (i interior)
 287                 (funcall dst-set-fn dst dst-word-offset
 288                          (funcall src-ref-fn src src-word-offset))
 289                 (incf src-word-offset)
 290                 (incf dst-word-offset))
 291               (unless (zerop final-bits)
 292                 ;; We are only writing part of the last word.
 293                 (let ((mask (start-mask final-bits))
 294                       (orig (funcall dst-ref-fn dst dst-word-offset))
 295                       (value (funcall src-ref-fn src src-word-offset)))
 296                   (declare (type unit mask orig value))
 297                   (funcall dst-set-fn dst dst-word-offset
 298                            (32bit-logical-or
 299                             (32bit-logical-and value mask)
 300                             (32bit-logical-andc2 orig mask))))))
 301              (t
 302               ;; We need to loop from right to left.
 303               (incf dst-word-offset words)
 304               (incf src-word-offset words)
 305               (unless (zerop final-bits)
 306                 (let ((mask (start-mask final-bits))
 307                       (orig (funcall dst-ref-fn dst dst-word-offset))
 308                       (value (funcall src-ref-fn src src-word-offset)))
 309                   (declare (type unit mask orig value))
 310                   (funcall dst-set-fn dst dst-word-offset
 311                            (32bit-logical-or
 312                             (32bit-logical-and value mask)
 313                             (32bit-logical-andc2 orig mask)))))
 314               (dotimes (i interior)
 315                 (decf src-word-offset)
 316                 (decf dst-word-offset)
 317                 (funcall dst-set-fn dst dst-word-offset
 318                          (funcall src-ref-fn src src-word-offset)))
 319               (unless (zerop dst-bit-offset)
 320                 (decf src-word-offset)
 321                 (decf dst-word-offset)
 322                 (let ((mask (end-mask (- dst-bit-offset)))
 323                       (orig (funcall dst-ref-fn dst dst-word-offset))
 324                       (value (funcall src-ref-fn src src-word-offset)))
 325                   (declare (type unit mask orig value))
 326                   (funcall dst-set-fn dst dst-word-offset
 327                            (32bit-logical-or
 328                             (32bit-logical-and value mask)
 329                             (32bit-logical-andc2 orig mask))))))))))
 330        (t
 331         ;; They aren't aligned.
 332         (multiple-value-bind (words final-bits)
 333             (floor (+ dst-bit-offset length) unit-bits)
 334           (declare (type word-offset words) (type bit-offset final-bits))
 335           (let ((src-shift (mod (- src-bit-offset dst-bit-offset) unit-bits))
 336                 (interior (floor (- length final-bits) unit-bits)))
 337             (declare (type bit-offset src-shift)
 338                      (type word-offset interior))
 339             (cond
 340              ((<= dst-offset src-offset)
 341               ;; We need to loop from left to right
 342               (let ((prev 0)
 343                     (next (funcall src-ref-fn src src-word-offset)))
 344                 (declare (type unit prev next))
 345                 (flet ((get-next-src ()
 346                          (setf prev next)
 347                          (setf next (funcall src-ref-fn src
 348                                              (incf src-word-offset)))))
 349                   (declare (inline get-next-src))
 350                   (unless (zerop dst-bit-offset)
 351                     (when (> src-bit-offset dst-bit-offset)
 352                       (get-next-src))
 353                     (let ((mask (end-mask (- dst-bit-offset)))
 354                           (orig (funcall dst-ref-fn dst dst-word-offset))
 355                           (value (32bit-logical-or
 356                                   (shift-towards-start prev src-shift)
 357                                   (shift-towards-end next (- src-shift)))))
 358                       (declare (type unit mask orig value))
 359                       (funcall dst-set-fn dst dst-word-offset
 360                                (32bit-logical-or
 361                                 (32bit-logical-and value mask)
 362                                 (32bit-logical-andc2 orig mask)))
 363                       (incf dst-word-offset)))
 364                   (dotimes (i interior)
 365                     (get-next-src)
 366                     (let ((value (32bit-logical-or
 367                                   (shift-towards-end next (- src-shift))
 368                                   (shift-towards-start prev src-shift))))
 369                       (declare (type unit value))
 370                       (funcall dst-set-fn dst dst-word-offset value)
 371                       (incf dst-word-offset)))
 372                   (unless (zerop final-bits)
 373                     (let ((value
 374                            (if (> (+ final-bits src-shift) unit-bits)
 375                                (progn
 376                                  (get-next-src)
 377                                  (32bit-logical-or
 378                                   (shift-towards-end next (- src-shift))
 379                                   (shift-towards-start prev src-shift)))
 380                                (shift-towards-start next src-shift)))
 381                           (mask (start-mask final-bits))
 382                           (orig (funcall dst-ref-fn dst dst-word-offset)))
 383                       (declare (type unit mask orig value))
 384                       (funcall dst-set-fn dst dst-word-offset
 385                                (32bit-logical-or
 386                                 (32bit-logical-and value mask)
 387                                 (32bit-logical-andc2 orig mask))))))))
 388              (t
 389               ;; We need to loop from right to left.
 390               (incf dst-word-offset words)
 391               (incf src-word-offset
 392                     (1- (ceiling (+ src-bit-offset length) unit-bits)))
 393               (let ((next 0)
 394                     (prev (funcall src-ref-fn src src-word-offset)))
 395                 (declare (type unit prev next))
 396                 (flet ((get-next-src ()
 397                          (setf next prev)
 398                          (setf prev (funcall src-ref-fn src
 399                                              (decf src-word-offset)))))
 400                   (declare (inline get-next-src))
 401                   (unless (zerop final-bits)
 402                     (when (> final-bits (- unit-bits src-shift))
 403                       (get-next-src))
 404                     (let ((value (32bit-logical-or
 405                                   (shift-towards-end next (- src-shift))
 406                                   (shift-towards-start prev src-shift)))
 407                           (mask (start-mask final-bits))
 408                           (orig (funcall dst-ref-fn dst dst-word-offset)))
 409                       (declare (type unit mask orig value))
 410                       (funcall dst-set-fn dst dst-word-offset
 411                                (32bit-logical-or
 412                                 (32bit-logical-and value mask)
 413                                 (32bit-logical-andc2 orig mask)))))
 414                   (decf dst-word-offset)
 415                   (dotimes (i interior)
 416                     (get-next-src)
 417                     (let ((value (32bit-logical-or
 418                                   (shift-towards-end next (- src-shift))
 419                                   (shift-towards-start prev src-shift))))
 420                       (declare (type unit value))
 421                       (funcall dst-set-fn dst dst-word-offset value)
 422                       (decf dst-word-offset)))
 423                   (unless (zerop dst-bit-offset)
 424                     (if (> src-bit-offset dst-bit-offset)
 425                         (get-next-src)
 426                         (setf next prev prev 0))
 427                     (let ((mask (end-mask (- dst-bit-offset)))
 428                           (orig (funcall dst-ref-fn dst dst-word-offset))
 429                           (value (32bit-logical-or
 430                                   (shift-towards-start prev src-shift)
 431                                   (shift-towards-end next (- src-shift)))))
 432                       (declare (type unit mask orig value))
 433                       (funcall dst-set-fn dst dst-word-offset
 434                                (32bit-logical-or
 435                                 (32bit-logical-and value mask)
 436                                 (32bit-logical-andc2 orig mask)))))))))))))))
 437   (values))
 438 \f
 439 ;;;; the actual bashers
 440
 441 (defun bit-bash-fill (value dst dst-offset length)
 442   (declare (type unit value) (type offset dst-offset length))
 443   (locally
 444    (declare (optimize (speed 3) (safety 0)))
 445    (do-constant-bit-bash dst dst-offset length value
 446                          #'%raw-bits #'%set-raw-bits)))
 447
 448 (defun system-area-fill (value dst dst-offset length)
 449   (declare (type unit value) (type offset dst-offset length))
 450   (locally
 451    (declare (optimize (speed 3) (safety 0)))
 452    (multiple-value-bind (dst dst-offset) (fix-sap-and-offset dst dst-offset)
 453      (do-constant-bit-bash dst dst-offset length value
 454                            #'word-sap-ref #'%set-word-sap-ref))))
 455
 456 (defun bit-bash-copy (src src-offset dst dst-offset length)
 457   (declare (type offset src-offset dst-offset length))
 458   (locally
 459    (declare (optimize (speed 3) (safety 0))
 460             (inline do-unary-bit-bash))
 461    (do-unary-bit-bash src src-offset dst dst-offset length
 462                       #'%raw-bits #'%set-raw-bits #'%raw-bits)))
 463
 464 (defun system-area-copy (src src-offset dst dst-offset length)
 465   (declare (type offset src-offset dst-offset length))
 466   (locally
 467    (declare (optimize (speed 3) (safety 0)))
 468    (multiple-value-bind (src src-offset) (fix-sap-and-offset src src-offset)
 469      (declare (type system-area-pointer src))
 470      (multiple-value-bind (dst dst-offset) (fix-sap-and-offset dst dst-offset)
 471        (declare (type system-area-pointer dst))
 472        (do-unary-bit-bash src src-offset dst dst-offset length
 473                           #'word-sap-ref #'%set-word-sap-ref
 474                           #'word-sap-ref)))))
 475
 476 (defun copy-to-system-area (src src-offset dst dst-offset length)
 477   (declare (type offset src-offset dst-offset length))
 478   (locally
 479    (declare (optimize (speed 3) (safety 0)))
 480    (multiple-value-bind (dst dst-offset) (fix-sap-and-offset dst dst-offset)
 481      (do-unary-bit-bash src src-offset dst dst-offset length
 482                         #'word-sap-ref #'%set-word-sap-ref #'%raw-bits))))
 483
 484 (defun copy-from-system-area (src src-offset dst dst-offset length)
 485   (declare (type offset src-offset dst-offset length))
 486   (locally
 487    (declare (optimize (speed 3) (safety 0)))
 488    (multiple-value-bind (src src-offset) (fix-sap-and-offset src src-offset)
 489      (do-unary-bit-bash src src-offset dst dst-offset length
 490                         #'%raw-bits #'%set-raw-bits #'word-sap-ref))))
 491
 492 ;;; a common idiom for calling COPY-TO-SYSTEM-AREA
 493 ;;;
 494 ;;; Copy the entire contents of the vector V to memory starting at SAP+OFFSET.
 495 (defun copy-byte-vector-to-system-area (bv sap &optional (offset 0))
 496   ;; FIXME: There should be a type like SB!VM:BYTE so that we can write this
 497   ;; type as (SIMPLE-ARRAY SB!VM:BYTE 1). Except BYTE is an external symbol of
 498   ;; package CL; so maybe SB!VM:VM-BYTE?
 499   (declare (type (simple-array (unsigned-byte 8) 1) bv))
 500   (declare (type sap sap))
 501   (declare (type fixnum offset))
 502   ;; FIXME: Actually it looks as though this, and most other calls
 503   ;; to COPY-TO-SYSTEM-AREA, could be written more concisely with BYTE-BLT.
 504   ;; Except that the DST-END-DST-START convention for the length is confusing.
 505   ;; Perhaps I could rename BYTE-BLT to BYTE-BLIT and replace the
 506   ;; DST-END argument with an N-BYTES argument?
 507   (copy-to-system-area bv
 508                        (* sb!vm:vector-data-offset sb!vm:word-bits)
 509                        sap
 510                        offset
 511                        (* (length bv) sb!vm:byte-bits)))