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