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 (defknown %rotate-byte (integer bit-index bit-index integer) integer
   6   (foldable flushable))
   7 (defknown %unsigned-32-rotate-byte ((integer -31 31) (unsigned-byte 32))
   8     (unsigned-byte 32)
   9   (foldable flushable))
  10
  11 (macrolet (;; see src/compiler/srctran.lisp
  12            (with-byte-specifier ((size-var pos-var spec) &body body)
  13              (once-only ((spec `(macroexpand ,spec))
  14                          (temp '(gensym)))
  15                         `(if (and (consp ,spec)
  16                                   (eq (car ,spec) 'byte)
  17                                   (= (length ,spec) 3))
  18                         (let ((,size-var (second ,spec))
  19                               (,pos-var (third ,spec)))
  20                           ,@body)
  21                         (let ((,size-var `(byte-size ,,temp))
  22                               (,pos-var `(byte-position ,,temp)))
  23                           `(let ((,,temp ,,spec))
  24                              ,,@body))))))
  25   (define-source-transform rotate-byte (count spec num)
  26     (with-byte-specifier (size pos spec)
  27       `(%rotate-byte ,count ,size ,pos ,num))))
  28
  29 (defoptimizer (%rotate-byte derive-type) ((count size posn num))
  30   ;; FIXME: this looks fairly unwieldy.  I'm sure it can be made
  31   ;; simpler, and also be made to deal with negative integers too.
  32   (let ((size (sb-c::lvar-type size)))
  33     (if (numeric-type-p size)
  34         (let ((size-high (numeric-type-high size))
  35               (num-type (sb-c::lvar-type num)))
  36           (if (and size-high
  37                    num-type
  38                    (<= size-high sb-vm:n-word-bits)
  39                    (csubtypep num-type
  40                               (specifier-type `(unsigned-byte ,size-high))))
  41               (specifier-type `(unsigned-byte ,size-high))
  42               *universal-type*))
  43         *universal-type*)))
  44
  45 (deftransform %rotate-byte ((count size pos integer)
  46                             ((constant-arg (member 0)) * * *) *)
  47   "fold identity operation"
  48   'integer)
  49
  50 (deftransform %rotate-byte ((count size pos integer)
  51                             ((integer -31 31)
  52                              (constant-arg (member 32))
  53                              (constant-arg (member 0))
  54                              (unsigned-byte 32)) *)
  55   "inline 32-bit rotation"
  56   ;; FIXME: What happens when, as here, the two type specifiers for
  57   ;; COUNT overlap?  Which gets to run first?
  58   '(%unsigned-32-rotate-byte count integer))
  59
  60 ;; Generic implementation for platforms that don't supply VOPs for 32-bit
  61 ;; rotate.
  62 #-(or x86 ppc)
  63 (deftransform %unsigned-32-rotate-byte ((.count. .integer.)
  64                                         ((integer -31 31)
  65                                          (unsigned-byte 32)) *)
  66   '(if (< .count. 0)
  67        (logior (ldb (byte 32 0) (ash .integer. (+ .count. 32)))
  68                (ash .integer. .count.))
  69        (logior (ldb (byte 32 0) (ash .integer. .count.))
  70                (ash .integer. (- .count. 32)))))