contrib/sb-rotate-byte/compiler.lisp

   1 (in-package "SB-ROTATE-BYTE")
   2
   3 (defknown rotate-byte (integer byte-specifier integer) integer
   4   (foldable flushable)
   5   :overwrite-fndb-silently t)
   6 (defknown %rotate-byte (integer bit-index bit-index integer) integer
   7   (foldable flushable)
   8   :overwrite-fndb-silently t)
   9 (defknown %unsigned-32-rotate-byte ((integer -31 31) (unsigned-byte 32))
  10     (unsigned-byte 32)
  11   (foldable flushable)
  12   :overwrite-fndb-silently t)
  13 #+64-bit
  14 (defknown %unsigned-64-rotate-byte ((integer -63 63) (unsigned-byte 64))
  15     (unsigned-byte 64)
  16   (foldable flushable)
  17   :overwrite-fndb-silently t)
  18
  19 (macrolet (;; see src/compiler/srctran.lisp
  20            (with-byte-specifier ((size-var pos-var spec) &body body)
  21              (once-only ((spec `(handler-case (macroexpand ,spec)
  22                                   (error ()
  23                                     (return (values nil t)))))
  24                          (temp '(gensym)))
  25                `(if (and (consp ,spec)
  26                          (eq (car ,spec) 'byte)
  27                          (= (length ,spec) 3))
  28                     (let ((,size-var (second ,spec))
  29                           (,pos-var (third ,spec)))
  30                       ,@body)
  31                     (let ((,size-var `(byte-size ,,temp))
  32                           (,pos-var `(byte-position ,,temp)))
  33                       `(let ((,,temp ,,spec))
  34                          ,,@body))))))
  35   (define-source-transform rotate-byte (count spec num)
  36     (block nil
  37       (with-byte-specifier (size pos spec)
  38         `(%rotate-byte ,count ,size ,pos ,num)))))
  39
  40 (defoptimizer (%rotate-byte derive-type) ((count size posn num))
  41   ;; FIXME: this looks fairly unwieldy.  I'm sure it can be made
  42   ;; simpler, and also be made to deal with negative integers too.
  43   (declare (ignore count))
  44   (let ((size (sb-c::lvar-type size))
  45         (posn (sb-c::lvar-type posn)))
  46     (if (and (numeric-type-p size)
  47              (numeric-type-p posn)
  48              (numeric-type-high size)
  49              (numeric-type-high posn))
  50         (let ((size-high (+ (numeric-type-high size)
  51                             (numeric-type-high posn)))
  52               (num-type (sb-c::lvar-type num)))
  53           (if (and (typep size-high '(integer 1))
  54                    num-type
  55                    (<= size-high sb-vm:n-word-bits)
  56                    (csubtypep num-type
  57                               (specifier-type `(unsigned-byte ,size-high))))
  58               (specifier-type `(unsigned-byte ,size-high))
  59               *universal-type*))
  60         *universal-type*)))
  61
  62 (deftransform %rotate-byte ((count size pos integer)
  63                             ((integer -31 31)
  64                              (constant-arg (member 32))
  65                              (constant-arg (member 0))
  66                              (unsigned-byte 32)) *)
  67   "inline 32-bit rotation"
  68   '(%unsigned-32-rotate-byte count integer))
  69
  70 ;; Generic implementation for platforms that don't supply VOPs for 32-bit
  71 ;; rotate.
  72 #-(or x86 x86-64 ppc arm arm64 riscv)
  73 (deftransform %unsigned-32-rotate-byte ((.count. .integer.)
  74                                         ((integer -31 31)
  75                                          (unsigned-byte 32)) *)
  76   '(if (< .count. 0)
  77        (logior (ldb (byte 32 0) (ash .integer. (+ .count. 32)))
  78                (ash .integer. .count.))
  79        (logior (ldb (byte 32 0) (ash .integer. .count.))
  80                (ash .integer. (- .count. 32)))))
  81
  82 #+64-bit
  83 (deftransform %rotate-byte ((count size pos integer)
  84                             ((integer -63 63)
  85                              (constant-arg (member 64))
  86                              (constant-arg (member 0))
  87                              (unsigned-byte 64)) *)
  88   "inline 64-bit rotation"
  89   '(%unsigned-64-rotate-byte count integer))
  90
  91 ;;; This transform needs to come after the others to ensure it gets
  92 ;;; first crack at a zero COUNT, since transforms are currently run
  93 ;;; latest-defined first.
  94 (deftransform %rotate-byte ((count size pos integer)
  95                             ((constant-arg (member 0)) t t t) *)
  96   "fold identity operation"
  97   'integer)