note FIRST fix in NEWS, fix stupid typo in tests
[sbcl.git] / 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 #+x86-64
11 (defknown %unsigned-64-rotate-byte ((integer -63 63) (unsigned-byte 64))
12     (unsigned-byte 64)
13   (foldable flushable))
14
15 (macrolet (;; see src/compiler/srctran.lisp
16            (with-byte-specifier ((size-var pos-var spec) &body body)
17              (once-only ((spec `(macroexpand ,spec))
18                          (temp '(gensym)))
19                         `(if (and (consp ,spec)
20                                   (eq (car ,spec) 'byte)
21                                   (= (length ,spec) 3))
22                         (let ((,size-var (second ,spec))
23                               (,pos-var (third ,spec)))
24                           ,@body)
25                         (let ((,size-var `(byte-size ,,temp))
26                               (,pos-var `(byte-position ,,temp)))
27                           `(let ((,,temp ,,spec))
28                              ,,@body))))))
29   (define-source-transform rotate-byte (count spec num)
30     (with-byte-specifier (size pos spec)
31       `(%rotate-byte ,count ,size ,pos ,num))))
32
33 (defoptimizer (%rotate-byte derive-type) ((count size posn num))
34   ;; FIXME: this looks fairly unwieldy.  I'm sure it can be made
35   ;; simpler, and also be made to deal with negative integers too.
36   (let ((size (sb-c::lvar-type size)))
37     (if (numeric-type-p size)
38         (let ((size-high (numeric-type-high size))
39               (num-type (sb-c::lvar-type num)))
40           (if (and size-high
41                    num-type
42                    (<= size-high sb-vm:n-word-bits)
43                    (csubtypep num-type
44                               (specifier-type `(unsigned-byte ,size-high))))
45               (specifier-type `(unsigned-byte ,size-high))
46               *universal-type*))
47         *universal-type*)))
48
49 (deftransform %rotate-byte ((count size pos integer)
50                             ((integer -31 31)
51                              (constant-arg (member 32))
52                              (constant-arg (member 0))
53                              (unsigned-byte 32)) *)
54   "inline 32-bit rotation"
55   '(%unsigned-32-rotate-byte count integer))
56
57 ;; Generic implementation for platforms that don't supply VOPs for 32-bit
58 ;; rotate.
59 #-(or x86 x86-64 ppc)
60 (deftransform %unsigned-32-rotate-byte ((.count. .integer.)
61                                         ((integer -31 31)
62                                          (unsigned-byte 32)) *)
63   '(if (< .count. 0)
64        (logior (ldb (byte 32 0) (ash .integer. (+ .count. 32)))
65                (ash .integer. .count.))
66        (logior (ldb (byte 32 0) (ash .integer. .count.))
67                (ash .integer. (- .count. 32)))))
68
69 #+x86-64
70 (deftransform %rotate-byte ((count size pos integer)
71                             ((integer -63 63)
72                              (constant-arg (member 64))
73                              (constant-arg (member 0))
74                              (unsigned-byte 64)) *)
75   "inline 64-bit rotation"
76   '(%unsigned-64-rotate-byte count integer))
77
78 ;;; This transform needs to come after the others to ensure it gets
79 ;;; first crack at a zero COUNT, since transforms are currently run
80 ;;; latest-defined first.
81 (deftransform %rotate-byte ((count size pos integer)
82                             ((constant-arg (member 0)) * * *) *)
83   "fold identity operation"
84   'integer)